[initial import
John Meacham <john@repetae.net>**20050419104820] adddir ./C
adddir ./DerivingDrift
adddir ./E
adddir ./FrontEnd
adddir ./Grin
adddir ./data
adddir ./docs
adddir ./lib
adddir ./lib/Data
adddir ./lib/Foreign
adddir ./lib/Foreign/C
adddir ./lib/Foreign/Marshal
adddir ./lib/System
adddir ./lib/Test
adddir ./lib/Test/QuickCheck
adddir ./lib/Text
adddir ./lib/Text/Show
addfile ./ANSI.hs
hunk ./ANSI.hs 1
+--  $Id: ANSI.hs,v 1.1 2002/08/13 17:20:52 john Exp john $
+
+-- 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.
+
+module ANSI(
+    move,
+    clrToEOL,
+    clrFromBOL,
+    clrLine,
+    clrToEOS,
+    clrFrombos,
+    clrScreen,
+    attrClear,
+    attrBold,
+    attrUnderline,
+    attrBlink,
+    attrReverse,
+    cursorOn,
+    cursorOff,
+    attrFG,
+    attrBG,
+    attr
+) where
+
+--import Prelude((++), show, Int, String)
+import List
+
+move ::  Int -> Int -> String
+move x y = "\27[" ++ (show y) ++ ";" ++ (show x) ++ ";H"
+clrToEOL = "\27[K" 
+clrFromBOL = "\27[1K" 
+clrLine = "\27[2K" 
+clrToEOS = "\27[J" 
+clrFrombos = "\27[1J" 
+clrScreen = "\27[2J" 
+attrClear = "\27[0m" 
+attrBold = "\27[1m" 
+attrUnderline = "\27[4m" 
+attrBlink = "\27[5m" 
+attrReverse = "\27[7m" 
+cursorOn = "\27[?25h" 
+cursorOff = "\27[?25l" 
+attrFG :: Int -> String
+attrFG c =  "\27[3" ++ (show c) ++ "m"
+attrBG :: Int -> String
+attrBG c =  "\27[4" ++ (show c) ++ "m"
+attr :: [Int] -> String
+attr cs = "\27[" ++ concat (intersperse ";" $ map show cs) ++ "m"
addfile ./Atom.hs
hunk ./Atom.hs 1
+-- arch-tag: da6b923d-c4d6-4918-9ce4-35ca0167d387
+module Atom(Atom, toPackedString, Atom.toString, atomIndex, fromStringIO, fromString, fromPackedStringIO, dumpAtomTable, ToAtom(..), FromAtom(..), intToAtom) where
+
+import PackedString
+import qualified Data.HashTable as HT
+import Foreign
+import Char
+--import Binary
+import System.IO.Unsafe
+import List(sort)
+import Data.Generics
+import Data.Monoid
+
+
+instance Monoid Atom where
+    mempty = toAtom nilPS
+    mappend x y = toAtom $ appendPS (fromAtom x)  (fromAtom y)
+    mconcat xs = toAtom $ concatPS (map fromAtom xs)
+
+{-# NOINLINE table #-}
+table :: HT.HashTable PackedString Atom
+table = unsafePerformIO (HT.new (==) (fromIntegral . hashPS))
+
+{-# NOINLINE reverseTable #-}
+reverseTable :: HT.HashTable Int Atom
+reverseTable = unsafePerformIO (HT.new (==) (fromIntegral))
+
+{-# NOINLINE intPtr #-}
+intPtr :: Ptr Int
+intPtr = unsafePerformIO (new 1)
+
+
+data Atom = Atom {-# UNPACK #-} !Int !PackedString 
+    deriving(Typeable, Data)
+
+instance Show Atom where
+    show = toString
+
+instance Read Atom where
+    readsPrec p s = [ (fromString x,y) |  (x,y) <- readsPrec p s] 
+
+toPackedString (Atom _ ps) = ps
+toString (Atom _ ps) = unpackPS ps
+atomIndex (Atom x _) = x
+
+{- these are separate in case operations are one-way -}
+class ToAtom a where
+    toAtom :: a -> Atom
+class FromAtom a where
+    fromAtom :: Atom -> a
+
+instance ToAtom String where
+    toAtom = fromString
+instance FromAtom String where
+    fromAtom = toString
+
+instance ToAtom PackedString where
+    toAtom x = unsafePerformIO $ fromPackedStringIO x
+instance FromAtom PackedString where
+    fromAtom = toPackedString
+
+instance ToAtom Atom where
+    toAtom x = x
+instance FromAtom Atom where
+    fromAtom x = x
+
+instance ToAtom Char where
+    toAtom x = toAtom [x]
+
+instance FromAtom Int where
+    fromAtom (Atom i _) = i
+
+instance Eq Atom where
+    Atom x _ == Atom y _ = x == y
+    Atom x _ /= Atom y _ = x /= y
+
+instance Ord Atom where
+    compare (Atom x _) (Atom y _) = compare x y
+    Atom x _ <= Atom y _ = x <= y
+    Atom x _ >= Atom y _ = x >= y
+    Atom x _ < Atom y _ = x < y
+    Atom x _ > Atom y _ = x > y
+    
+fromString :: String -> Atom
+fromString xs = unsafePerformIO $ fromStringIO xs
+
+fromStringIO :: String -> IO Atom
+fromStringIO cs = fromPackedStringIO (packString cs)
+
+fromPackedStringIO :: PackedString -> IO Atom
+fromPackedStringIO ps = HT.lookup table ps >>= \x -> case x of
+    Just z -> return z
+    Nothing -> do
+        i <- peek intPtr
+        poke intPtr (i + 2)
+        let a = Atom i ps
+        HT.insert table ps a
+        HT.insert reverseTable i a
+        return a
+
+dumpAtomTable = do
+    x <- HT.toList table
+    mapM_ putStrLn [ show i ++ " " ++ show ps  | (_,Atom i ps) <- sort x]
+        
+    
+intToAtom :: Monad m => Int -> m Atom
+intToAtom i = unsafePerformIO $  HT.lookup reverseTable i >>= \x -> case x of
+    Just x -> return (return x)
+    Nothing -> return $ fail $ "intToAtom: " ++ show i 
+    
+{-
+    xs <- HT.toList table
+    case [ at | (_,at@(Atom i' _)) <- xs, i' == i ] of
+        [a] -> return (return a)
+        [] -> return $ fail $ "intToAtom: " ++ show i 
+        _ -> error "intToAtom: can't happen"
+instance Binary Atom where
+    get bh = do
+        ps <- get bh
+        a <- fromPackedStringIO ps
+        return a
+    put_ bh (Atom _ ps) = put_ bh ps
+        
+-}
+
addfile ./Binary.hs
hunk ./Binary.hs 1
+{-# OPTIONS -fallow-overlapping-instances #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Binary I/O library, with special tweaks for GHC
+--
+-- Based on the nhc98 Binary library, which is copyright
+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
+-- Under the terms of the license for that software, we must tell you
+-- where you can obtain the original version of the Binary library, namely
+--     http://www.cs.york.ac.uk/fp/nhc98/
+
+-- arch-tag: 1418e09a-9a18-4dca-a0fc-9262c9d97beb
+
+module Binary
+  ( {-type-}  Bin,
+    {-class-} Binary(..),
+    {-type-}  BinHandle,
+
+   openBinIO, openBinIO_,
+   openBinMem,
+--   closeBin,
+
+   seekBin,
+   tellBin,
+   castBin,
+
+   writeBinMem,
+   readBinMem,
+
+   isEOFBin,
+
+   -- for writing instances:
+   putByte,
+   getByte,
+
+   -- lazy Bin I/O
+   lazyGet,
+   lazyPut,
+
+   -- GHC only:
+   ByteArray(..),
+   getByteArray,
+   putByteArray
+
+   --getBinFileWithDict,	-- :: Binary a => FilePath -> IO a
+   --putBinFileWithDict,	-- :: Binary a => FilePath -> ModuleName -> a -> IO ()
+
+  ) where
+
+
+--import FastString
+import FastMutInt
+
+import Data.Array.IO
+import Data.Array
+import Data.Bits
+import Data.Int
+import Data.Word
+import Data.IORef
+import Data.Char		( ord, chr )
+import Control.Monad	 
+import Control.Exception	( throwDyn )
+import System.IO as IO
+import System.IO.Unsafe		( unsafeInterleaveIO )
+import System.IO.Error		( mkIOError, eofErrorType )
+import GHC.Real			( Ratio(..) )
+import GHC.Exts
+import GHC.IOBase	 	( IO(..) )
+import GHC.Word			( Word8(..) )
+import PackedString
+import Atom
+import Time
+import Data.Array.IArray
+import Data.Array.Base
+
+
+{-
+#if __GLASGOW_HASKELL__ < 503
+type BinArray = MutableByteArray RealWorld Int
+newArray_ bounds     = stToIO (newCharArray bounds)
+unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
+unsafeRead  arr ix   = stToIO (readWord8Array arr ix)
+#if __GLASGOW_HASKELL__ < 411
+newByteArray#        = newCharArray#
+#endif
+hPutArray h arr sz   = hPutBufBAFull h arr sz
+hGetArray h sz       = hGetBufBAFull h sz
+
+mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
+mkIOError t location maybe_hdl maybe_filename
+  = IOException (IOError maybe_hdl t location ""
+#if __GLASGOW_HASKELL__ > 411
+		         maybe_filename
+#endif
+  		)
+eofErrorType = EOF
+
+
+#ifndef SIZEOF_HSWORD
+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
+#endif
+
+#else
+type BinArray = IOUArray Int Word8
+#endif
+-}
+
+--  #define SIZEOF_HSINT 4
+
+type BinArray = IOUArray Int Word8
+---------------------------------------------------------------
+--		BinHandle
+---------------------------------------------------------------
+
+data BinHandle
+  = BinMem {		-- binary data stored in an unboxed array
+     off_r :: !FastMutInt,		-- the current offset
+     sz_r  :: !FastMutInt,		-- size of the array (cached)
+     arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))
+    }
+	-- XXX: should really store a "high water mark" for dumping out
+	-- the binary data to a file.
+
+  | BinIO {		-- binary data stored in a file
+     off_r :: !FastMutInt,		-- the current offset (cached)
+     hdl   :: !IO.Handle		-- the file handle (must be seekable)
+   }
+	-- cache the file ptr in BinIO; using hTell is too expensive
+	-- to call repeatedly.  If anyone else is modifying this Handle
+	-- at the same time, we'll be screwed.
+
+--getUserData :: BinHandle -> UserData
+--getUserData bh = bh_usr bh
+
+--setUserData :: BinHandle -> UserData -> BinHandle
+--setUserData bh us = bh { bh_usr = us }
+
+
+---------------------------------------------------------------
+--		Bin
+---------------------------------------------------------------
+
+newtype Bin a = BinPtr Int 
+  deriving (Eq, Ord, Show, Bounded)
+
+castBin :: Bin a -> Bin b
+castBin (BinPtr i) = BinPtr i
+
+---------------------------------------------------------------
+--		class Binary
+---------------------------------------------------------------
+
+class Binary a where
+    put_   :: BinHandle -> a -> IO ()
+    put    :: BinHandle -> a -> IO (Bin a)
+    get    :: BinHandle -> IO a
+
+    -- define one of put_, put.  Use of put_ is recommended because it
+    -- is more likely that tail-calls can kick in, and we rarely need the
+    -- position return value.
+    put_ bh a = do put bh a; return ()
+    put bh a  = do p <- tellBin bh; put_ bh a; return p
+
+putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
+putAt bh p x = do seekBin bh p; put bh x; return ()
+
+getAt  :: Binary a => BinHandle -> Bin a -> IO a
+getAt bh p = do seekBin bh p; get bh
+
+openBinIO_ :: IO.Handle -> IO BinHandle
+openBinIO_ h = openBinIO h 
+
+openBinIO :: IO.Handle -> IO BinHandle
+openBinIO h = do
+  r <- newFastMutInt
+  writeFastMutInt r 0
+  return (BinIO  r h)
+
+openBinMem :: Int -> IO BinHandle
+openBinMem size
+ | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0"
+ | otherwise = do
+   arr <- newArray_ (0,size-1)
+   arr_r <- newIORef arr
+   ix_r <- newFastMutInt
+   writeFastMutInt ix_r 0
+   sz_r <- newFastMutInt
+   writeFastMutInt sz_r size
+   return (BinMem ix_r sz_r arr_r)
+
+tellBin :: BinHandle -> IO (Bin a)
+tellBin (BinIO   r _)   = do ix <- readFastMutInt r; return (BinPtr ix)
+tellBin (BinMem  r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
+
+seekBin :: BinHandle -> Bin a -> IO ()
+seekBin (BinIO  ix_r h) (BinPtr p) = do 
+  writeFastMutInt ix_r p
+  hSeek h AbsoluteSeek (fromIntegral p)
+seekBin h@(BinMem  ix_r sz_r a) (BinPtr p) = do
+  sz <- readFastMutInt sz_r
+  if (p >= sz)
+	then do expandBin h p; writeFastMutInt ix_r p
+	else writeFastMutInt ix_r p
+
+isEOFBin :: BinHandle -> IO Bool
+isEOFBin (BinMem  ix_r sz_r a) = do
+  ix <- readFastMutInt ix_r
+  sz <- readFastMutInt sz_r
+  return (ix >= sz)
+isEOFBin (BinIO  ix_r h) = hIsEOF h
+
+writeBinMem :: BinHandle -> FilePath -> IO ()
+writeBinMem (BinIO  _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
+writeBinMem (BinMem  ix_r sz_r arr_r) fn = do
+  h <- openBinaryFile fn WriteMode
+  arr <- readIORef arr_r
+  ix  <- readFastMutInt ix_r
+  hPutArray h arr ix
+  hClose h
+
+readBinMem :: FilePath -> IO BinHandle
+-- Return a BinHandle with a totally undefined State
+readBinMem filename = do
+  h <- openBinaryFile filename ReadMode
+  filesize' <- hFileSize h
+  let filesize = fromIntegral filesize'
+  arr <- newArray_ (0,filesize-1)
+  count <- hGetArray h arr filesize
+  when (count /= filesize)
+        (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
+  hClose h
+  arr_r <- newIORef arr
+  ix_r <- newFastMutInt
+  writeFastMutInt ix_r 0
+  sz_r <- newFastMutInt
+  writeFastMutInt sz_r filesize
+  return (BinMem ix_r sz_r arr_r)
+
+-- expand the size of the array to include a specified offset
+expandBin :: BinHandle -> Int -> IO ()
+expandBin (BinMem  ix_r sz_r arr_r) off = do
+   sz <- readFastMutInt sz_r
+   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
+   arr <- readIORef arr_r
+   arr' <- newArray_ (0,sz'-1)
+   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i | i <- [ 0 .. sz-1 ] ]
+   writeFastMutInt sz_r sz'
+   writeIORef arr_r arr'
+   return ()
+expandBin (BinIO  _ _) _ = return ()
+	-- no need to expand a file, we'll assume they expand by themselves.
+
+-- -----------------------------------------------------------------------------
+-- Low-level reading/writing of bytes
+
+putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 h@(BinMem  ix_r sz_r arr_r) w = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r
+	-- double the size of the array if it overflows
+    if (ix >= sz) 
+        then do 
+            expandBin h ix
+            putWord8 h w
+        else do 
+            arr <- readIORef arr_r
+            unsafeWrite arr ix w
+            writeFastMutInt ix_r (ix+1)
+            return ()
+
+putWord8 (BinIO  ix_r h) w = do
+    ix <- readFastMutInt ix_r
+    hPutChar h (chr (fromIntegral w))	-- XXX not really correct
+    writeFastMutInt ix_r (ix+1)
+    return ()
+
+getWord8 :: BinHandle -> IO Word8
+getWord8 (BinMem  ix_r sz_r arr_r) = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r
+    when (ix >= sz)  $
+	ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+    arr <- readIORef arr_r
+    w <- unsafeRead arr ix
+    writeFastMutInt ix_r (ix+1)
+    return w
+getWord8 (BinIO  ix_r h) = do
+    ix <- readFastMutInt ix_r
+    c <- hGetChar h
+    writeFastMutInt ix_r (ix+1)
+    return $! (fromIntegral (ord c))	-- XXX not really correct
+
+{-# INLINE putByte #-}
+putByte :: BinHandle -> Word8 -> IO ()
+putByte bh w = putWord8 bh w
+
+{-# INLINE getByte #-}
+getByte :: BinHandle -> IO Word8
+getByte = getWord8
+
+-- -----------------------------------------------------------------------------
+-- Primitve Word writes
+
+instance Binary Word8 where
+  put_ = putWord8
+  get  = getWord8
+
+instance Binary Word16 where
+  put_ h w = do -- XXX too slow.. inline putWord8?
+    putByte h (fromIntegral (w `shiftR` 8))
+    putByte h (fromIntegral (w .&. 0xff))
+  get h = do
+    w1 <- getWord8 h
+    w2 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
+
+
+instance Binary Word32 where
+  put_ h w = do
+    putByte h (fromIntegral (w `shiftR` 24))
+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
+    putByte h (fromIntegral (w .&. 0xff))
+  get h = do
+    w1 <- getWord8 h
+    w2 <- getWord8 h
+    w3 <- getWord8 h
+    w4 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 24) .|. 
+	       (fromIntegral w2 `shiftL` 16) .|. 
+	       (fromIntegral w3 `shiftL`  8) .|. 
+	       (fromIntegral w4))
+
+
+instance Binary Word64 where
+  put_ h w = do
+    putByte h (fromIntegral (w `shiftR` 56))
+    putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
+    putByte h (fromIntegral (w .&. 0xff))
+  get h = do
+    w1 <- getWord8 h
+    w2 <- getWord8 h
+    w3 <- getWord8 h
+    w4 <- getWord8 h
+    w5 <- getWord8 h
+    w6 <- getWord8 h
+    w7 <- getWord8 h
+    w8 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 56) .|. 
+	       (fromIntegral w2 `shiftL` 48) .|. 
+	       (fromIntegral w3 `shiftL` 40) .|. 
+	       (fromIntegral w4 `shiftL` 32) .|. 
+	       (fromIntegral w5 `shiftL` 24) .|. 
+	       (fromIntegral w6 `shiftL` 16) .|. 
+	       (fromIntegral w7 `shiftL`  8) .|. 
+	       (fromIntegral w8))
+
+-- -----------------------------------------------------------------------------
+-- Primitve Int writes
+
+instance Binary Int8 where
+  put_ h w = put_ h (fromIntegral w :: Word8)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word8))
+
+instance Binary Int16 where
+  put_ h w = put_ h (fromIntegral w :: Word16)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word16))
+
+instance Binary Int32 where
+  put_ h w = put_ h (fromIntegral w :: Word32)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word32))
+
+instance Binary Int64 where
+  put_ h w = put_ h (fromIntegral w :: Word64)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word64))
+
+-- -----------------------------------------------------------------------------
+-- Instances for standard types
+
+instance Binary () where
+    put_ bh () = return ()
+    get  _     = return ()
+--    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
+
+instance Binary Bool where
+    put_ bh b = putByte bh (fromIntegral (fromEnum b))
+    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
+--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
+
+instance Binary Char where
+    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
+    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+--    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
+
+instance Binary Int where
+--  #if SIZEOF_HSINT == 4
+    put_ bh i = put_ bh (fromIntegral i :: Int32)
+    get  bh = do
+	x <- get bh
+	return $! (fromIntegral (x :: Int32))
+--  #elif SIZEOF_HSINT == 8
+--    put_ bh i = put_ bh (fromIntegral i :: Int64)
+--    get  bh = do
+--	x <- get bh
+--	return $! (fromIntegral (x :: Int64))
+--  #else
+--  #error "unsupported sizeof(HsInt)"
+--  #endif
+
+instance Binary ClockTime where
+    put_ bh ct = do
+	let t = toUTCTime ct
+	put_ bh (ctYear t)
+	put_ bh (fromEnum $ ctMonth t)
+	put_ bh (ctDay t)
+	put_ bh (ctHour t)
+	put_ bh (ctMin t)
+	put_ bh (ctSec t)
+    get bh = do
+	year <- get bh
+	month <- fmap toEnum $ get bh 
+	day <- get bh 
+	hour <- get bh 
+	min <- get bh 
+	sec <- get bh 
+	return $ toClockTime $ (toUTCTime epoch) {ctYear = year, ctDay = day, ctMonth = month, ctHour = hour, ctMin = min, ctSec = sec}
+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}
+
+instance Binary PackedString where
+    put_ bh (PS a) = put_ bh a
+    get bh = fmap PS $ get bh 
+
+--put_ bh $ (snd $ Data.Array.IArray.bounds a) + 1
+--mapM_ (put_ bh) (Data.Array.IArray.elems a)
+--sz <- get bh
+--x <- sequence $ replicate sz (get bh)
+--return $ PS (Data.Array.IArray.listArray (0,sz - 1) x) 
+
+--put_ bh ps = put_ bh (unpackPS ps) 
+--get bh = liftM packString $ get bh
+--put_ bh ps = putNList_ bh (unpackPS ps) 
+--get bh = liftM packString $ getNList bh
+    
+-- putNList_ bh xs = do
+--     put_ bh (length xs)
+--     mapM_ (put_ bh) xs
+-- 
+-- getNList bh = do
+--     l <- get bh
+--     sequence $ replicate l (get bh)
+
+{-
+instance Binary [Char] where
+    put_ bh cs = put_ bh (packString cs)
+    get bh = do
+        ps <- get bh
+        return $ unpackPS ps
+-}
+
+instance Binary a => Binary [a] where
+    put_ bh []     = putByte bh 0
+    put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
+    get bh         = do h <- getWord8 bh
+                        case h of
+                          0 -> return []
+                          _ -> do x  <- get bh
+                                  xs <- get bh
+                                  return (x:xs)
+
+instance (Binary a, Binary b) => Binary (a,b) where
+    put_ bh (a,b) = do put_ bh a; put_ bh b
+    get bh        = do a <- get bh
+                       b <- get bh
+                       return (a,b)
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         return (a,b,c)
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
+    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         return (a,b,c,d)
+
+instance Binary a => Binary (Maybe a) where
+    put_ bh Nothing  = putByte bh 0
+    put_ bh (Just a) = do putByte bh 1; put_ bh a
+    get bh           = do 
+        h <- getWord8 bh
+        case h of
+            0 -> return Nothing
+            _ -> do 
+                x <- get bh 
+                return (Just x)
+
+instance (Binary a, Binary b) => Binary (Either a b) where
+    put_ bh (Left  a) = do putByte bh 0; put_ bh a
+    put_ bh (Right b) = do putByte bh 1; put_ bh b
+    get bh            = do h <- getWord8 bh
+                           case h of
+                             0 -> do a <- get bh ; return (Left a)
+                             _ -> do b <- get bh ; return (Right b)
+
+
+
+-- these flatten the start element. hope that's okay!
+instance Binary (UArray Int Word8) where
+    put_ bh@(BinIO ix_r h) ua = do
+        let sz = rangeSize (Data.Array.IO.bounds ua)
+        ix <- readFastMutInt ix_r 
+        put_ bh sz
+        ua <- unsafeThaw ua
+        hPutArray h ua sz
+        writeFastMutInt ix_r (ix + sz + 4)
+    put_ bh (UArray s e ba) = do
+        let sz = (rangeSize (s,e))
+        put_ bh sz
+        case sz of
+            I# i -> putByteArray bh ba i
+    get bh@(BinIO ix_r h) = do
+        ix <- readFastMutInt ix_r 
+        sz <- get bh 
+        ba <- newArray_ (0, sz - 1)
+        hGetArray h ba sz 
+        writeFastMutInt ix_r (ix + sz + 4)
+        ba <- unsafeFreeze ba 
+        return ba
+    get  bh = do
+        sz <- get bh 
+        BA ba <- getByteArray bh sz
+        return $ UArray 0 (sz - 1) ba
+
+ {-
+
+instance (Ix a, Binary a) => Binary (UArray a Word8) where
+    put_ bh (UArray s e ba) = do
+        put_ bh s
+        put_ bh e
+        case (rangeSize (s,e)) of
+            I# i -> putByteArray bh ba i
+    get  bh = do
+        s <- get bh 
+        e <- get bh
+        BA ba <- getByteArray bh (rangeSize (s,e))
+        return $ UArray s e ba
+
+-} 
+--  #ifdef __GLASGOW_HASKELL__
+
+instance Binary Integer where
+    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
+    put_ bh (J# s# a#) = do
+ 	p <- putByte bh 1;
+	put_ bh (I# s#)
+	let sz# = sizeofByteArray# a#  -- in *bytes*
+	put_ bh (I# sz#)  -- in *bytes*
+	putByteArray bh a# sz#
+   
+    get bh = do 
+	b <- getByte bh
+	case b of
+	  0 -> do (I# i#) <- get bh
+		  return (S# i#)
+	  _ -> do (I# s#) <- get bh
+		  sz <- get bh
+		  (BA a#) <- getByteArray bh sz
+		  return (J# s# a#)
+
+putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
+putByteArray bh a s# = loop 0#
+  where loop n# 
+	   | n# ==# s# = return ()
+	   | otherwise = do
+	   	putByte bh (indexByteArray a n#)
+		loop (n# +# 1#)
+
+getByteArray :: BinHandle -> Int -> IO ByteArray
+getByteArray bh (I# sz) = do
+  (MBA arr) <- newByteArray sz 
+  let loop n
+	   | n ==# sz = return ()
+	   | otherwise = do
+		w <- getByte bh 
+		writeByteArray arr n w
+		loop (n +# 1#)
+  loop 0#
+  freezeByteArray arr
+
+
+data ByteArray = BA ByteArray#
+data MBA = MBA (MutableByteArray# RealWorld)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+  case newByteArray# sz s of { (# s, arr #) ->
+  (# s, MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
+  (# s, BA arr #) }
+
+writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
+
+writeByteArray arr i (W8# w) = IO $ \s ->
+  case writeWord8Array# arr i w s of { s ->
+  (# s, () #) }
+
+indexByteArray a# n# = W8# (indexWord8Array# a# n#)
+
+instance (Integral a, Binary a) => Binary (Ratio a) where
+    put_ bh (a :% b) = do put_ bh a; put_ bh b
+    get bh = do a <- get bh; b <- get bh; return (a :% b)
+--  #endif
+
+instance Binary (Bin a) where
+  put_ bh (BinPtr i) = put_ bh i
+  get bh = do i <- get bh; return (BinPtr i)
+
+-- -----------------------------------------------------------------------------
+-- Lazy reading/writing
+
+lazyPut :: Binary a => BinHandle -> a -> IO ()
+lazyPut bh a = do
+	-- output the obj with a ptr to skip over it:
+    pre_a <- tellBin bh
+    put_ bh pre_a	-- save a slot for the ptr
+    put_ bh a		-- dump the object
+    q <- tellBin bh 	-- q = ptr to after object
+    putAt bh pre_a q 	-- fill in slot before a with ptr to q
+    seekBin bh q	-- finally carry on writing at q
+
+lazyGet :: Binary a => BinHandle -> IO a
+lazyGet bh = do
+    p <- get bh		-- a BinPtr
+    p_a <- tellBin bh
+    a <- unsafeInterleaveIO (getAt bh p_a)
+    seekBin bh p -- skip over the object for now
+    return a
+
+ 
+{-
+---------------------------------------------------------
+--		Reading and writing FastStrings
+---------------------------------------------------------
+
+putFS bh (FastString id l ba) = do
+  put_ bh (I# l)
+  putByteArray bh ba l
+putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
+	-- Note: the length of the FastString is *not* the same as
+	-- the size of the ByteArray: the latter is rounded up to a
+	-- multiple of the word size.
+  
+{- -- possible faster version, not quite there yet:
+getFS bh@BinMem{} = do
+  (I# l) <- get bh
+  arr <- readIORef (arr_r bh)
+  off <- readFastMutInt (off_r bh)
+  return $! (mkFastSubStringBA# arr off l)
+-}
+getFS bh = do
+  (I# l) <- get bh
+  (BA ba) <- getByteArray bh (I# l)
+  return $! (mkFastSubStringBA# ba 0# l)
+
+{-
+instance Binary FastString where
+  put_ bh f@(FastString id l ba) =
+    case getUserData bh of { 
+	UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do
+    out <- readIORef out_r
+    let uniq = getUnique f
+    case lookupUFM out uniq of
+	Just (j,f)  -> put_ bh j
+	Nothing -> do
+	   j <- readIORef j_r
+	   put_ bh j
+	   writeIORef j_r (j+1)
+	   writeIORef out_r (addToUFM out uniq (j,f))
+    }
+  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))
+
+  get bh = do 
+	j <- get bh
+	return $! (ud_dict (getUserData bh) ! j)
+-}
+-}
+
+instance Binary Atom where
+    get bh = do
+        ps <- get bh
+        a <- fromPackedStringIO ps
+        return a
+    put_ bh a = put_ bh (toPackedString a)
+        
addfile ./C/FromGrin.hs
hunk ./C/FromGrin.hs 1
+module C.FromGrin(compileGrin) where
+
+import Atom
+import C.Gen
+import Control.Monad.Identity
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+import C.Prims
+import Data.Monoid
+import DDataUtil()
+import Doc.DocLike
+import Doc.PPrint
+import E.Pretty(render)
+import FreeVars
+import GenUtil
+import Grin.Grin
+import Grin.HashConst
+import Grin.Show
+import List
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Text.PrettyPrint.HughesPJ as P
+import RawFiles
+import Text.PrettyPrint.HughesPJ(nest,($$),($+$))
+import VConsts
+import qualified Seq
+
+
+toType TyTag = tag_t
+toType (TyNode) = pnode_t
+toType (TyTup []) = CTypeBasic "void" 
+toType (TyPtr TyNode) = toType TyNode  -- for now, we use pointers to nodes for everything 
+--toType (TyPtr t) = CTypePointer (toType t)
+toType (Ty s) = CTypeBasic $ fromAtom s
+--    | a == tIntzh = CTypeBasic "HsInt"
+--    | a == tCharzh = CTypeBasic "HsChar"
+--    | otherwise = CTypeBasic (fromAtom s)
+
+
+toStruct t = text $ 's':(show $ toCIdent $ t) 
+toTag t = text $ (show $ toCIdent $ t) 
+
+toStructT t = CTypeStruct (toStruct t) 
+toStructTP t = CTypePointer (toStructT t)
+
+size_t = CTypeBasic "size_t"
+tag_t = CTypeBasic "tag_t"
+pnode_t = CTypePointer node_t
+node_t = (CTypeBasic "node_t")
+
+toVName (V n) | n < 0 = text $ 'g':show (- n)
+toVName (V n) = text $ 'v':show n
+
+
+data Todo = TodoReturn | TodoExp CExpr | TodoNothing 
+
+ccaf (v,val) = text "/* " <> text (show v) <> text " = " <> (text $ render (prettyVal val)) <> text "*/\n" <> text "static node_t _" <> toVName v <> text ";\n" <> text "#define " <> toVName v <+>  text "(&_" <> toVName v <> text ")\n";
+cfunc te (n,Tup as :-> body) = do
+        s <- runReaderT (cb body) TodoReturn
+        return $ cfunction { cFuncComments = show n, cFuncReturnType = toType r, cFuncName = toTag n, cFuncArgs = [ (toType t, toVName v) | Var v t <- as  ], cFuncBody = s  } where
+    Identity (_,r) = findArgsType te n
+
+
+
+cVal :: MonadState HcHash m => Val -> m CExpr
+cVal (Var n _) = return $  CEIdent (toVName n)
+cVal (Const (NodeC h _)) | h == tagHole = return $ CEIdent "NULL"
+cVal (Const h) = do
+    (_,i) <- newConst h
+    return $ CEIdent ( 'c':show i )
+cVal (Lit i _) = return $ CEDoc (show i)
+cVal (Tag t) = return $ CEIdent (toTag t)
+cVal x = return $  CEDoc  ("/* cVal: " ++ show x  ++ " */")
+
+
+-- cb (Fetch (Var n _) :>>= Var n' t :-> e ) = return [CSAuto (toType t) (toVName n'), CSAssign (CEIdent (] 
+
+statement s = tell $ (Seq.single s,mempty)
+
+newNode (NodeC t _) | t == tagHole = do 
+    return $  CEFunCall "malloc" [CESizeof node_t]
+newNode (NodeC t as) = do
+    statement (CSAuto pnode_t "tmp")
+    --let tmp = CEVar (CTypePointer (toStructT t)) "tmp" 
+    let tmp = CEIdent "tmp"
+        --tmp' = CECast (toStructTP t) tmp
+        tmp' = CEIndirect tmp (toStruct t)
+    statement (CSAssign tmp $ CEFunCall "malloc" [CESizeof (if tagIsWHNF t then toStructT t else node_t)])
+    statement (CSAssign  (CEDot tmp' "tag") (CEDoc (toTag t)) )
+    as' <- mapM cVal as
+    mapM_ statement [CSAssign  (CEDot tmp' ('a':show i)) a | a <- as' | i <- [1 ..] ]
+    return $ CECast pnode_t tmp
+
+
+cexp (Update v@Var {} (NodeC t as)) = do
+    v' <- cVal v
+    as' <- mapM cVal as
+    let tmp' = CECast (toStructTP t) v'
+    statement (CSAssign  (CEIndirect tmp' "tag") (CEDoc (toTag t)) )
+    as' <- mapM cVal as
+    mapM_ statement [CSAssign  (CEIndirect tmp' ('a':show i)) a | a <- as' | i <- [1 ..] ]
+    return $ CEDoc ""
+    
+cexp (Update v z) = do  -- TODO eliminate unknown updates
+    v' <- cVal v
+    z' <- cVal z
+    let tag = CEIndirect z' "any.tag"
+    return $ CEFunCall "memcpy" [v',z',CEFunCall "jhc_sizeof" [tag]]
+cexp (Fetch v) = cVal v 
+cexp (Store n@NodeC {}) = newNode n 
+cexp (Return n@NodeC {}) = newNode n
+cexp (Return x) = cVal x 
+cexp (Cast x t) = cVal x >>= return . CECast (toType t) 
+cexp (Error s t) = do
+    statement (CSExpr (CEFunCall "jhc_error" [CEDoc (show s)])) 
+    return $ CECast (toType t) (CEDoc "0")
+cexp (App a vs) = do
+    vs' <- mapM cVal vs 
+    return $ CEFunCall (toTag a) vs'
+cexp (Prim p vs) | APrim _ req <- primAPrim p  = tell (mempty,req) >> convertPrim p vs
+cexp e = return $ CEDoc ("/* ERROR " ++ show e ++ " */")
+
+convertPrim p vs 
+    | APrim (CConst s _) _ <- primAPrim p = do
+        return $ CEDoc s
+    | APrim (CCast _ to) _ <- primAPrim p, [a] <- vs = do
+        a' <- cVal a
+        return $ CECast (CTypeBasic to) a'
+    | APrim (Operator n [ta] r) _ <- primAPrim p, [a] <- vs = do
+        a' <- cVal a
+        return $ CECast (CTypeBasic r) (CEUOp n a')
+    | APrim (Operator n [ta,tb] r) _ <- primAPrim p, [a,b] <- vs = do
+        a' <- cVal a
+        b' <- cVal b
+        return $ CECast (CTypeBasic r) (CEOp n a' b') -- (CECast (CTypeBasic ta) a') (CECast  | v <- vs' | t <- as ])
+    | APrim (Func _ n as r) _ <- primAPrim p = do
+        vs' <- mapM cVal vs
+        return $ CECast (CTypeBasic r) (CEFunCall n [ CECast (CTypeBasic t) v | v <- vs' | t <- as ])
+    | APrim (Peek t) _ <- primAPrim p, [v] <- vs = do
+        v' <- cVal v
+        return $ CEDoc ("*((" <> t <+> "*)" <> (parens $ pprint v') <> char ')')
+    | APrim (Poke t) _ <- primAPrim p, [v,x] <- vs = do
+        v' <- cVal v
+        x' <- cVal x
+        return $ CEDoc ("*((" <> t <+> "*)" <> (parens $ pprint v') <> text ") = " <> pprint x')
+    | APrim (AddrOf t) _ <- primAPrim p, [] <- vs = do
+        return $ CEDoc ('&':t)
+
+--    | Just r <- getPrefix "prim_const." pName , [] <- vs = do
+--        return $ CEDoc r
+--    | Just r <- getPrefix "prim_op_aaa." pName , [a,b] <- vs = do
+--        a' <- cVal a
+--        b' <- cVal b
+--        return $ CEOp r a' b'
+--    | Just r <- getPrefix "prim_op_aaB." pName , [a,b] <- vs = do
+--        a' <- cVal a
+--        b' <- cVal b
+--        return $ CEOp r a' b'
+--    | Just r <- getPrefix "prim_op_aa." pName , [a] <- vs = do
+--        a' <- cVal a
+--        return $ CEUOp r a'
+--    |  "@primEq" `isPrefixOf` pName, [a,b] <- vs = do
+--        a' <- cVal a
+--        b' <- cVal b
+--        (_,true) <- newConst vTrue 
+--        (_,false) <- newConst vFalse
+--        return $ CETernary (CEOp "==" a' b') (CEIdent ('c':show true)) (CEIdent ('c':show false))
+--    |  "@primCompare" `isPrefixOf` pName, [a,b] <- vs = do
+--        a' <- cVal a
+--        b' <- cVal b
+--        (_,eq) <- newConst $ vOrdering EQ
+--        (_,gt) <- newConst $ vOrdering GT
+--        (_,lt) <- newConst $ vOrdering LT
+--        let ti x = CEIdent ('c':show x)
+--        return $ CETernary (CEOp ">" a' b') (ti gt)  (CETernary (CEOp "==" a' b') (ti eq) (ti lt)) 
+--    |  toAtom "@primNegate" ==  primName p, [a] <- vs = do
+--        a' <- cVal a
+--        return $  (CEOp "-" (CEDoc "0") a') 
+--    | toAtom "@putChar" == primName p, [a] <- vs = do
+--        a' <- cVal a
+--        return $ CEFunCall "putchar" [a']
+--    | toAtom "@getChar" == primName p, [] <- vs = do
+--        tell [CSAuto (CTypeBasic "int") "gc"]
+--        tell [CSAssign (CEIdent "gc") (CEFunCall "getchar" [])]
+--        return $ CEIdent "gc"
+ --   | Just n <- lookup (primName p) bops, [a,b] <- vs = doBop n a b 
+--    where pName = fromAtom $ primName p
+
+--doBop n a b = do
+--    a' <- cVal a
+--    b' <- cVal b
+--    return $ CEOp n a' b'
+    
+--bops = [(toAtom "@primTimes", "*"), (toAtom "@primPlus", "+"), (toAtom "@primMinus","-")]
+
+declVar (Var n t) = CSAuto (toType t) (toVName n)
+
+cb (Prim p [a,b] :>>= Tup [q,r] :-> e') | primName p == toAtom "@primQuotRem" = do
+    a' <- cVal a
+    b' <- cVal b
+    r' <- cVal r
+    q' <- cVal q
+    ss' <- cb e'
+    return $ [declVar q, declVar r, CSAssign q' (CEOp "/" a' b'), CSAssign r' (CEOp "%" a' b') ] ++ ss'
+    
+cb (Return v :>>= (NodeC t as) :-> e') = do
+    v' <- cVal v 
+    --let tmp = CECast (toStructTP t)  v' 
+    let tmp = CEIndirect v' (toStruct t) 
+    as' <- mapM cVal as
+    --let ass = [CSAssign  a (CEIndirect tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
+    let ass = [CSAssign  a (CEDot tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
+    ss' <- cb e'
+    return (map declVar as  ++ ass ++ ss')
+cb (Fetch v :>>= (NodeC t as) :-> e') = do
+    v' <- cVal v 
+    --let tmp = CECast (toStructTP t)  v' 
+    let tmp = CEIndirect v' (toStruct t) 
+    as' <- mapM cVal as
+    --let ass = [CSAssign  a (CEIndirect tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
+    let ass = [CSAssign  a (CEDot tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
+    ss' <- cb e'
+    return (map declVar as  ++ ass ++ ss')
+cb (e :>>= Tup [] :-> e') = do
+    ss <- local (const (TodoNothing)) (cb e)
+    ss' <- cb e'
+    return (ss ++ ss')
+cb (e :>>= v@(Var _ _) :-> e') = do
+    v' <- cVal v 
+    ss <- local (const (TodoExp v')) (cb e)
+    ss' <- cb e'
+    return (declVar v:ss ++ ss')
+cb (Case v@(Var _ t) ls) | t == TyNode = do
+    v' <- cVal v 
+    let tag = CEIndirect v' "any.tag"
+        da (v@(Var {}) :-> e) = do
+            v'' <- cVal v 
+            e' <- cb e 
+            return $ (Nothing,[declVar v,CSAssign v'' v'] ++ e')  
+        da ((NodeC t as) :-> e) = do
+            as' <- mapM cVal as
+            e' <- cb e 
+            --let tmp = CECast (toStructTP t)  v' 
+            let tmp = CEIndirect v' (toStruct t) 
+            --let ass = [CSAssign  a (CEIndirect tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
+            let ass = [CSAssign  a (CEDot tmp ('a':show i)) | a <- as' | i <- [1 ..] ]
+            return $ (Just (toTag t), map declVar as ++ ass ++ e')  
+    ls' <- mapM da ls 
+    return [CSSwitch tag ls' ]
+cb (Case v@(Var _ t) ls) = do
+    v' <- cVal v 
+    v'' <- return (if t `elem` ptrs then CECast (CTypeBasic "uintptr_t") v' else v')
+    let da (v@(Var {}) :-> e) = do
+            v'' <- cVal v 
+            e' <- cb e 
+            return $ (Nothing,[declVar v,CSAssign v'' v'] ++ e')  
+        da ((Lit i _) :-> e) = do
+            e' <- cb e 
+            return $ (Just (show i), e')  
+    ls' <- mapM da ls 
+    return [CSSwitch v'' ls' ]
+    
+
+    
+cb e = do
+    x <- ask
+    (e,(ss',req)) <- runWriterT $ cexp e 
+    tell req
+    let ss = Seq.toList ss'
+    case x of
+        TodoReturn -> return $ ss ++ [CSReturn e]
+        TodoExp v -> return $ ss ++ [CSAssign v e]
+        TodoNothing | e == CEDoc "" -> return ss
+        TodoNothing -> return $ ss ++ [CSExpr e]
+
+
+ptrs = [Ty $ toAtom "HsPtr", Ty $ toAtom "HsFunPtr"]
+
+include fn = text "#include <" <> text fn <> text ">" 
+
+compileGrin :: Grin -> (String,[String])
+compileGrin grin = (hsffi_h ++ jhc_rts_c ++ P.render ans ++ "\n", snub (reqLibraries req))  where
+    tags = (tagHole,[]):sortUnder (show . fst) [ (t,runIdentity $ findArgs (grinTypeEnv grin) t) | t <- Set.toList $ freeVars (snds $ grinFunctions grin) `mappend` freeVars (snds $ grinCafs grin), tagIsTag t]
+    et = text "typedef enum {" $$ nest 4 (P.fsep (punctuate P.comma (map (toTag . fst) tags))) $$ text  "} tag_t;" 
+    --ans = vcat $ [text "#include \"HsFFI.h\"",text "#include <stdlib.h>",text "#include <stdio.h>",text "#include <string.h>",text "#include <unistd.h>",text "#include <malloc.h>",text "",et,text "",text "typedef union node node_t;",text ""] ++ map cs tags ++ [text "",cn,text "",so,text "",text "/* Begin CAFS */"] ++ map ccaf (grinCafs grin) ++ [text "", consts, text "",text  "/* Begin Functions */",jhc_error] ++ map prettyFuncP funcs ++ (map prettyFunc funcs) ++ [mf]
+    ans = vcat $ map include (snub $ reqIncludes req) ++ [text "",et,text ""] ++ map cs tags ++ [text "",cn,text "",so,text "",text "/* Begin CAFS */"] ++ map ccaf (grinCafs grin) ++ [text "", consts, text "",text  "/* Begin Functions */"] ++ map prettyFuncP funcs ++ (map prettyFunc funcs) 
+    cs (t,ts) = prettyDecl $ CStruct (toStruct t) ((tag_t, "tag"):map cst (zip [1..] ts))
+    cst (i,t) = (toType t, text $ 'a':show i) 
+    cn = text $  "union node {\n  struct { tag_t tag; } any;\n" <> mconcat (map cu (fsts tags)) <> text "};" 
+    cu t = text "  struct" <+> (toStruct t) <+> toStruct t <> text ";\n"
+    so = prettyDecl $ CFunc size_t "jhc_sizeof" [(tag_t,"tag")] [CSDoc $ "switch(tag) {\n" ++ concatMap cs (fsts tags) ++ "}\n_exit(33);"] where
+        cs t = text "  case " <> toTag t <> char ':' <+> text "return sizeof(struct " <> toStruct t <> text ");\n"
+    funcs = sortUnder cFuncName funcs'
+    --(funcs',fh) =  runState sdo emptyHcHash
+    ((funcs',req),fh) = runState  (runWriterT (mapM (cfunc $ grinTypeEnv grin) $ grinFunctions grin)) emptyHcHash
+    consts = P.vcat (map cc (Grin.HashConst.toList fh)) where
+        cc nn@(HcNode a zs,i) = comm $$ cd $$ def where
+            comm = text "/* " <> tshow (nn) <> text " */"
+            cd = text "static struct " <> toStruct a <+> text "_c" <> tshow i <+> text "= {" <> hsep (punctuate P.comma (toTag a:rs)) <> text "};" 
+            def = text "#define c" <> tshow i <+> text "((node_t *)&_c" <> tshow i <> text ")"
+            rs = [ f z undefined |  z <- zs ]
+            --ts = findArgs (grinTypeEnv grin) a
+            f (Right i) _ = text $ 'c':show i
+            --f (Left i) _ = tshow i
+            f (Left (Var n _)) _ =  toVName n 
+            f (Left (Lit i _)) _ = tshow i
+            f (Left (Tag t)) _ = toTag t
+            
+
+    
+--mf = text "int main(int argc, char *argv[]) { XAmain(); return 0; }"
+--jhc_error = text "static void jhc_error(char *s) { fputs(s,stderr); fputs(\"\\n\",stderr);  exit(1); }"
+
+
addfile ./C/Gen.hs
hunk ./C/Gen.hs 1
+module C.Gen where
+
+
+--import Pretty
+import qualified Text.PrettyPrint.HughesPJ as P
+import Text.PrettyPrint.HughesPJ(nest,render,($$),($+$))
+import List(partition)
+import Control.Monad.State
+import GenUtil
+import Numeric
+import Char
+import Atom
+import Doc.DocLike
+import Doc.PPrint
+import List
+import Maybe
+
+
+data CType = CTypeBasic String | CTypePointer CType | CTypeStruct String
+    deriving(Ord,Eq)
+data CDecl = CFunc CType String [(CType,String)] [CStatement] | CVar CType String | CStruct String [(CType,String)]
+    deriving(Ord,Eq)
+data CStatement = CSAssign CExpr CExpr | CSExpr CExpr | CSAuto CType String | CSReturn CExpr | CSDoc String | CSSwitch CExpr [(Maybe String,[CStatement])]
+    deriving(Ord,Eq)
+data CExpr = CEIdent String | CEFunCall String [CExpr] | CELiteral CLit | CEDot CExpr String | CEIndirect CExpr String | CESizeof CType | CECast CType CExpr | CEEval CExpr | CEDoc String | CEVar CType String | CETernary CExpr CExpr CExpr | CEOp String CExpr CExpr  | CEUOp String CExpr 
+    deriving(Ord,Eq)
+data CLit = CLitChar Char | CLitInt Int | CLitNull
+    deriving(Ord,Eq)
+ 
+data CFunction = CFunction {
+    cFuncComments :: String,
+    cFuncName :: String,
+    cFuncReturnType :: CType,
+    cFuncArgs :: [(CType,String)],
+    cFuncPublic :: Bool,
+    cFuncBody :: [CStatement]
+    }
+
+cfunction = CFunction { cFuncComments = "", cFuncName = "_unknown", cFuncReturnType = CTypeBasic "void", cFuncArgs = [], cFuncPublic = False, cFuncBody = [] } 
+
+instance PPrint P.Doc CFunction where
+    pprint = prettyFunc
+
+instance DocLike d => PPrint d CExpr where
+    pprint = prettyExpr
+
+prettyFunc :: CFunction -> P.Doc
+prettyFunc cf =  ans where
+    comm = if null (cFuncComments cf) then empty else  text "/*" <+> text (cFuncComments cf) <+> text "*/"
+    ans = comm $$ prettyDecl (fdecl cf)
+
+prettyFuncP cf = prettyProto (fdecl cf)
+
+fdecl cf = CFunc (cFuncReturnType cf) (cFuncName cf) (cFuncArgs cf) (cFuncBody cf)
+    
+
+data CCode = CCode {
+    cCodeIncludes :: [String],
+    cCodeFunctions :: [CFunction]
+    --cCodeGlobalVars :: [(CType,String)]
+    }
+
+newtype CIdent = CIdent String
+
+class ToCIdent a where
+    toCIdent :: a -> CIdent
+
+
+instance ToCIdent String where
+    toCIdent xs = CIdent $ concatMap f xs where
+        f '.' = "XD"
+        f '@' = "XA"
+        f ',' = "XC"
+        f '(' = "XL"
+        f ')' = "XR"
+        f '_' = "_"
+        f 'X' = "XX"
+        f c | isAlphaNum c = [c]
+        f c = 'X':showHex (ord c) ""
+
+instance ToCIdent Atom where
+    toCIdent a = toCIdent (fromAtom a :: String)
+
+instance Show CIdent where
+    show (CIdent x) = x
+
+    
+-----------------------------------------
+-- high level monad for generating C code
+-----------------------------------------
+
+
+data CGenState = CGenState {
+    genStateDecls :: [CDecl],
+    genStateStatements :: [CStatement],
+    genUnique :: {-# UNPACK #-} !Int
+    }
+
+cGenState = CGenState {
+    genStateDecls = [],
+    genStateStatements = [],
+    genUnique = 1
+    }
+
+newtype CGen m a = CGen (StateT CGenState m a)
+    deriving(Monad, MonadState CGenState, MonadTrans)
+
+runCGen u (CGen x) = runStateT x (cGenState { genUnique = u })
+
+runSubCGen :: Monad m => CGen m a -> CGen m ([CStatement], a)
+runSubCGen x = do
+    CGenState { genUnique = v } <- get
+    (r,CGenState { genStateDecls = d, genStateStatements = s, genUnique = v' }) <- lift $ runCGen v x -- runStateT x ([],[],v)
+    addDecls d
+    modify (\cg -> cg { genUnique = v' })
+    return (s,r)
+
+addDecls :: Monad m => [CDecl] -> CGen m ()
+addDecls d' = modify f where
+    f cg = cg { genStateDecls = genStateDecls cg ++ d'}
+
+addStmts :: Monad m => [CStatement] -> CGen m ()
+addStmts s' = modify f where
+    f cg  =  cg { genStateStatements = genStateStatements cg ++ s'}
+
+newIdent :: Monad m => CGen m String
+newIdent = do
+    let f cg  =  cg { genUnique = genUnique cg + 1}
+    CGenState { genUnique = i } <- get
+    modify f
+    return ('_':show i)
+
+{-
+
+instance Monad m => Unique (CGen m) where
+    modifyGetUniqueState f = do
+	modify (\(x,y,z) -> (x,y,f z))
+	(_,_,z) <- get 
+	return z
+
+instance Monad m => UniqueProducer (CGen m) where
+    newUniq = newUniq_d
+-}
+
+---------------------------------------
+-- utility functions for declaring code
+---------------------------------------
+
+-- naming helpers
+
+func n = 'f':show n
+auto n = 'a':show n
+var n = 'v':show n
+
+funcE n = ceIdent (func n)
+autoE n = ceIdent (auto n)
+varE n = ceIdent (var n)
+
+-- simple constructors
+
+ptr p = CTypePointer p
+cInt i = (CELiteral (CLitInt i))
+cVar v = (ceIdent v)
+
+structT n = ptr $ CTypeStruct ('s':show n)
+ceIdent = CEIdent
+ceFunCall = CEFunCall
+ceError s = CEDoc (text "error_thunk" <> parens (text (show s)))
+
+-- simple values
+tEval = CTypeBasic "eval_fn_t"
+cVoid = CTypeBasic "void"
+cThunk = CTypePointer (CTypeBasic "thunk_t")
+cNull = (CELiteral CLitNull)
+cVoidStar = CTypePointer cVoid
+ctInt = CTypeBasic "int"
+tEv = (CTypePointer $ CTypeBasic "eval_thunk_t")
+
+
+
+
+cAssign n e = CSAssign (autoE n) e
+
+addComment s = addStmts [CSDoc (text "/* " <> text s <> text " */")]
+
+{-
+cCase :: Monad m => CExpr -> ([(CLit,(CGen m CExpr))],(CGen m CExpr)) -> (CGen m CExpr)
+cCase e (as,d) = do
+    r <- newIdent
+    te <- newIdent
+    fas <- mapM (f r) as
+    gd <- g r d
+    addStmts [CSAuto cVoidStar r, CSAuto tEv te,CSAssign (ceIdent te) e]
+    addStmts  [CSDoc ( text "switch" <> parens (prettyExpr $ CECast ctInt e) <> text "{" $$ nest 8 (vcat fas $$ gd) $$ text "}")]
+    return (ceIdent r)  where
+	f r (l,v)  = do 
+	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
+	    return $ (text "case" <+> prettyLit l <> colon ) $$  prettyCode s $$ text "break;"
+	g r v = do
+	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
+	    return $ text "default:" $$ prettyCode s $$ text "break;"
+-}
+{-
+cCase :: Monad m => CExpr -> ([(CLit,(CGen m CExpr))],(CGen m CExpr)) -> (CGen m CExpr)
+cCase e (as,d) = do
+    r <- newIdent
+    te <- newIdent
+    fas <- mapM (f r) as
+    gd <- g r d
+    addStmts [CSAuto cVoidStar r, CSAuto tEv te,CSAssign (ceIdent te) e]
+    addStmts  [CSDoc ( text "switch" <> parens (prettyExpr $ CECast ctInt (CEEval (ceIdent te))) <> text "{" $$ nest 8 (vcat fas $$ gd) $$ text "}")]
+    return (ceIdent r)  where
+	f r (l,v)  = do 
+	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
+	    return $ (text "case" <+> prettyLit l <> colon ) $$  prettyCode s $$ text "break;"
+	g r v = do
+	    s <- cBlock (v >>= \e -> addStmts [CSAssign (ceIdent r) e])
+	    return $ text "default:" $$ prettyCode s $$ text "break;"
+-}
+
+cBlock :: Monad m => CGen m () -> CGen m [CStatement]
+cBlock v = do
+    (s,()) <- runSubCGen v 
+    let (as, ns) = partition isAuto s
+    addStmts as
+    return ns
+{-
+
+cBlock v = do
+    (_,_,i) <- get
+    ((),(d,s,ni)) <- lift ( runCGen i v) -- runStateT v ([],[], i))
+    addDecls d
+    let (as, ns) = partition isAuto s
+    addStmts as
+    modify $ liftT3 (id,id,const ni)
+    return ns
+    
+-}
+
+
+declThunk :: String -> CDecl
+declThunk n = CVar (CTypePointer (CTypeBasic "thunk_t")) n
+
+cThunkInd :: String -> CExpr
+cThunkInd n = CEIndirect (ceIdent "thunk") n
+
+cInd n v = CEIndirect (autoE n) ('v':show v)
+cTInd n = CEIndirect (ceIdent "thunk") ('v':show n)
+
+cStructClosure n vs = [CStruct n ((cVoidStar, "eval"):map f vs)] where
+    f n = (cThunk, n)
+
+cAlloc t = CECast (CTypePointer t) $ CEFunCall "malloc" [CESizeof t]
+cAllocThunk i = cAlloc (CTypeStruct ('s':show i))
+
+
+----------------------------------
+-- code emmission, Pretty Printing
+----------------------------------
+
+
+prettyC :: [CDecl] -> String
+prettyC (cf) = render (header $$$ 
+    ((vcat $ map prettyDecl sts) $$$ (vcat $ map prettyProto fns) $$$ 
+	(vcat $ map prettyDecl vars) $$$ (vcat $ map prettyDecl fns)) $$$ text "")  where
+    vars = filter isVar cf
+    fns = filter isFn cf
+    sts = filter isStruct cf
+    isVar (CVar _ _) = True
+    isVar _ = False
+    isFn (CFunc _ _ _ _) = True
+    isFn _ = False
+    isStruct (CStruct _ _) = True
+    isStruct _ = False
+    header =  text "#include <malloc.h>" $$ 
+	text "#include \"jhc_rts.h\"" $$ text "" 
+
+--a $$ b = a <> char '\n' <>  b
+
+--a $+$ b = a $$ b 
+--semi = char ';'
+--nest _ x = x
+
+a $$$ b = a $$ text "" $$ b
+
+
+prettyArgs [] = text "void"
+prettyArgs args = hcat (punctuate (text ", ") (map (\(t,i) -> prettyType t <+> text i) $ args))  
+
+prettyDecl (CFunc rt n args code) = text "static" <+> prettyType rt $$ text n <> text "(" <> prettyArgs args <> text ")" $+$
+    text "{" $+$ nest 8 (prettyCode code) $+$ text "}"
+prettyDecl  (CVar t n) = prettyType t <+> text n <> semi
+prettyDecl (CStruct n vs) = text "struct" <+> text n <+> text "{" $$ nest 8 (vcat (map sd vs)) $$ text "};" where
+    sd (t,n) = prettyType t <+> text n <> semi
+
+prettyProto (CFunc rt n args _) = text "static" <+> prettyType rt <+> text n <> parens (prettyArgs args) <> semi
+prettyProto (CStruct n _) = text "struct" <+> text n <> semi
+--prettyProto (CStruct n vs) = text "struct" <+> text n <+> text "{" $$ nest 8 (vcat (map sd vs)) $$ text "};" where
+--    sd (t,n) = prettyType t <+> text n <> semi
+
+prettyCode = prettyCode' True
+prettyCode' showSa (ss) = vcat $ map ps ((if showSa then snub sa else [])  ++ sb) where
+    ps (CSAssign n e) = prettyExpr n <+> text "=" <+> prettyExpr e <> text ";"
+    ps (CSExpr e) = prettyExpr e <> semi
+    ps (CSAuto t n) = prettyType t <+> text n <> semi
+    ps (CSReturn e) = text "return" <+> prettyExpr e <> semi
+    ps (CSSwitch e ts) = text "switch" <+> parens (prettyExpr e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where
+        sc (Just x,ss) = text "case" <+> text x <> char ':' $$ nest 4  (prettyCode' False ss $$ text "break;")
+        sc (Nothing,ss) = text "default:" $$ nest 4  (prettyCode' False ss) $$ text "break;"
+        md = if any isNothing (fsts ts) then empty else text "default: jhc_case_fell_off(__LINE__);" 
+    ps (CSDoc d) = text d
+    sa = collectAuto ss 
+    sb = filter (not . isAuto) ss 
+    collectAuto ss = filter isAuto ss ++ concatMap f ss where
+        f (CSSwitch _ ts) = concat [collectAuto x | (_,x) <- ts]
+        f _ = []
+    --(sa, sb) = partition isAuto ss
+
+isAuto (CSAuto _ _) = True
+isAuto _ = False
+
+prettyLit :: DocLike d => CLit -> d
+prettyLit (CLitInt i) = text (show i)
+prettyLit (CLitChar c) = text $ show c
+prettyLit CLitNull = text "NULL"
+
+
+
+prettyExpr :: DocLike d => CExpr -> d
+prettyExpr (CEIdent n) = text n
+prettyExpr (CELiteral l) = prettyLit l
+prettyExpr (CEFunCall n ce) = text n <> parens (hcat (intersperse (text ", ") (map prettyExpr ce)))
+prettyExpr (CEDot (CEIndirect (CEIdent n) x) y) = text n <> text "->" <> text x <> text "." <> text y
+prettyExpr (CEDot (CEIndirect e x) y) = (parens $ prettyExpr e) <> text "->" <> text x <> text "." <> text y
+prettyExpr (CEIndirect (CEIdent i) n) = text i <> text "->" <> text n
+prettyExpr (CEIndirect e n) = (parens $ prettyExpr e) <> text "->" <> text n
+prettyExpr (CEDot e n) = (parens $ prettyExpr e) <> text "." <> text n
+prettyExpr (CESizeof t) = text "sizeof" <>(parens $ prettyType t) 
+prettyExpr (CECast t e) = parens (prettyType t) <> prettyExpr e
+prettyExpr (CEEval e) = (prettyExpr (CEIndirect e "eval"))  <>  parens (prettyExpr e)
+prettyExpr (CEDoc d) = text d
+prettyExpr (CEOp s a b) = parens $ prettyExpr a <+> text s <+> prettyExpr b
+prettyExpr (CEUOp s a) = parens $ text s <+> prettyExpr a
+prettyExpr (CETernary x a b) = parens $ prettyExpr x <+> char '?' <+> prettyExpr a <+> char ':' <+> prettyExpr b
+
+prettyType :: DocLike d => CType -> d
+prettyType (CTypeBasic s) = text s
+prettyType (CTypePointer t) = prettyType t <> text "*"
+prettyType (CTypeStruct s) = text "struct" <+> text s
+
+
addfile ./C/Prims.hs
hunk ./C/Prims.hs 1
+module C.Prims where
+
+import Data.Monoid
+import Data.Generics
+import Binary
+import Doc.DocLike
+import Doc.PPrint
+
+data Requires = Requires { 
+    reqIncludes :: [String],
+    reqLibraries :: [String]
+    } deriving(Typeable, Data, Eq, Ord, Show)
+    {-! derive: Monoid, GhcBinary !-}
+
+type ExtType = String
+
+emptyExtType = ""
+
+data Prim = 
+    PrimPrim String          -- Special primitive implemented in the compiler somehow.
+    | CConst String ExtType  -- C code which evaluates to a constant            
+    | Operator String  [ExtType] ExtType   -- C operator
+    | Func Bool String [ExtType] ExtType   -- function call with C calling convention
+    | IFunc [ExtType] ExtType              -- indirect function call
+    | AddrOf String                        -- address of linker name 
+    | Peek ExtType                         -- read value from memory
+    | Poke ExtType                         -- write value to memory
+    | CCast ExtType ExtType                -- Cast from one basic type to another, possibly lossy.
+    deriving(Typeable, Data, Eq, Ord, Show)
+    {-! derive: GhcBinary !-}
+
+parsePrimString s = do
+    ws@(_:_) <- return $ words s 
+    let v = case last ws of 
+            '&':s -> AddrOf s
+            s -> Func False s [] emptyExtType
+    let f opt@('-':'l':_) = Requires [] [opt]
+        f s = Requires [s] []
+    return (APrim v (mconcat (map f (init ws))))
+    
+
+primPrim s = APrim (PrimPrim s) mempty
+
+data APrim = APrim Prim Requires 
+    deriving(Typeable, Data, Eq, Ord, Show)
+    {-! derive: GhcBinary !-}
+
+instance PPrint d Prim  => PPrint d APrim where
+    pprint (APrim p _) = pprint p
+
+instance DocLike d => PPrint d Prim where
+    pprint (PrimPrim t) = text t
+    pprint (CConst s t) = parens (text t) <> parens (text s) 
+    pprint (Operator s xs r) = parens (text r) <> text s <> tupled (map text xs) 
+    pprint (Func _ s xs r) = parens (text r) <> text s <> tupled (map text xs) 
+    pprint (IFunc xs r) = parens (text r) <> parens (char '*') <> tupled (map text xs) 
+    pprint (AddrOf s) = char '&' <> text s
+    pprint (Peek t) = char '*' <> text t
+    pprint (Poke t) = char '=' <> text t
+    pprint (CCast _ t) = parens (text t)
+
addfile ./COPYING
hunk ./COPYING 1
+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.  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.
addfile ./CanType.hs
hunk ./CanType.hs 1
+module CanType where
+
+
+class CanType a e | a -> e where
+    getType :: a -> e
+
+
addfile ./CharIO.hs
hunk ./CharIO.hs 1
+module CharIO(
+    putStr,
+    putStrLn,
+    putErr, 
+    putErrLn, 
+    putErrDie, 
+    CharIO.readFile, 
+    CharIO.print, 
+    CharIO.hGetContents,
+    runMain
+    ) where
+
+import Prelude hiding(putStr, putStrLn)
+import qualified Prelude
+import IO hiding(putStr, putStrLn)
+import Control.Exception
+import UTF8
+import System
+import Char
+
+toUTF8 s = (map (chr. fromIntegral) $ toUTF s) 
+fromUTF8 s = fromUTF (map (fromIntegral . ord) s) 
+
+flushOut = Control.Exception.catch  (hFlush stdout) (\_ -> return ())
+
+putStr = Prelude.putStr . toUTF8  
+putStrLn = Prelude.putStrLn . toUTF8  
+putErr s = flushOut >> IO.hPutStr IO.stderr (toUTF8 s)
+putErrLn s = flushOut >> IO.hPutStrLn IO.stderr (toUTF8 s)
+putErrDie s = flushOut >> IO.hPutStrLn IO.stderr (toUTF8 s) >> System.exitFailure
+print x = putStrLn $ show x
+
+readFile fn = Prelude.readFile fn >>= \s -> return (fromUTF8 s)
+hGetContents h =  IO.hGetContents h >>= \s -> return (fromUTF8 s)
+
+runMain :: IO a -> IO ()
+runMain action = do 
+    Control.Exception.catch (action >> return ()) (\x -> putErrDie $ show x)
addfile ./DDataUtil.hs
hunk ./DDataUtil.hs 1
+module DDataUtil(Elems(..),Member(..)) where
+
+import qualified Data.IntSet as IS
+import qualified Data.IntMap as IM
+import qualified Data.Set as Set
+import qualified Data.Map as Map 
+
+
+
+class Elems xs k v  | xs -> k v where
+    elems :: xs -> [v]
+    keys :: xs -> [k]
+    assocs :: xs -> [(k,v)]
+
+    assocs x = zip (keys x) (elems x)
+    elems x = [ y | (_,y) <- assocs x]
+    keys x =  [ x | (x,_) <- assocs x]
+    
+instance Elems (Set.Set x) x x where
+    elems = Set.elems
+    keys = Set.elems
+
+instance Elems IS.IntSet Int Int where
+    elems = IS.elems
+    keys = IS.elems
+
+instance Elems (Map.Map a b) a b where
+    assocs = Map.assocs
+    keys = Map.keys
+    elems = Map.elems
+
+instance Elems (IM.IntMap x) Int x where
+    assocs = IM.assocs
+    keys = IM.keys
+    elems = IM.elems
+
+instance Elems x y z => Elems (Maybe x) y z where
+    keys Nothing = []
+    keys (Just x) = keys x
+    elems (Just x) = elems x
+    elems Nothing = []
+    assocs (Just x) = assocs x
+    assocs Nothing = []
+
+class Member m k | m -> k where
+    member :: k -> m -> Bool
+    notMember :: k -> m -> Bool
+
+    notMember k m = not $ member k m
+    member k m = not $ notMember k m
+
+instance Ord a => Member (Set.Set a) a where
+    member = Set.member
+instance Ord k => Member (Map.Map k v) k where
+    member = Map.member
+instance Member (IM.IntMap v) Int where
+    member = IM.member
+instance Member IS.IntSet Int where
+    member = IS.member
+
+
+
+{-
+instance Monad Set.Set where
+    a >>= b = Set.unions (map b (Set.toList a))
+    return x = Set.single x
+    fail _ = Set.empty
+-}
+{-
+instance Monoid IS.IntSet where
+    mempty = IS.empty
+    mappend = IS.union
+    mconcat = IS.unions
+
+instance Monoid (IM.IntMap a) where
+    mempty = IM.empty
+    mappend = IM.union
+    mconcat = IM.unions
+    
+instance Ord a => Monoid (Set.Set a) where
+    mempty = Set.empty
+    mappend = Set.union
+    mconcat = Set.unions
+
+instance Ord k => Monoid (Map.Map k v ) where
+    mempty = Map.empty
+    mappend = Map.union
+    mconcat = Map.unions
+
+
+
+instance Functor IM.IntMap where
+    fmap = IM.map
+
+--instance Ord k => Functor (Map.Map k) where
+--    fmap = Map.map
+    
+
+instance HasSize (Map.Map a b) where
+    size = Map.size
+instance HasSize (Set.Set a) where
+    size = Set.size
+instance HasSize IS.IntSet where
+    size = IS.size
+-}
+    
addfile ./DataConstructors.hs
hunk ./DataConstructors.hs 1
+module DataConstructors(
+    Constructor(..),
+    getConstructor,
+    toDataTable,
+    DataTable(..),
+    showDataTable,
+    slotTypes,
+    lookupCType,
+    lookupCType',
+    followAliases,
+    typesCompatable,
+    getConstructorArities,
+    getSiblings
+    ) where
+
+import Binary
+import Control.Monad.Identity
+import Control.Monad.Writer
+import Data.Map as Map hiding(map)
+import Doc.DocLike
+import Doc.Pretty
+import E.E
+import E.Pretty
+import E.Shadow
+import E.Subst
+import GenUtil
+import HasSize
+import HsSyn
+import List(sortBy)
+import MapBinaryInstance()
+import Name
+import PrimitiveOperators
+import qualified Data.IntMap as IM
+import qualified Name
+import qualified Seq
+import Representation
+import SameShape
+import VConsts
+
+
+tipe (TAp t1 t2) = eAp (tipe t1) (tipe t2)
+tipe (TArrow t1 t2) =  EPi (tVr 0 (tipe t1)) (tipe t2)
+tipe (TCon (Tycon n k)) =  ELit (LitCons (toName TypeConstructor n) [] (kind k))
+tipe (TGen n (Tyvar _ _ k)) = EVar (tVr ((n + 1) * 2 ) (kind k))
+tipe (TVar (Tyvar _ n k)) = error "tipe': Tyvar"
+kind Star = eStar
+kind (Kfun k1 k2) = EPi (tVr 0 (kind k1)) (kind k2)
+kind (KVar _) = error "Kind variable still existing."
+{-
+data DataType = Alias |
+    Boxed               -- ^ values are always tagged and the domain includes closures which evaluate to a term of this type as well as it's data constructors.
+    | BoxedPrimitive    -- ^ values are always tagged and the domain includes closures which evaluate to a term of this type, other values in the domain are system dependent however.
+    | UnboxedPrimitive  -- ^ values do not have a tag and the representation is system dependent
+    | Unboxed           -- ^ values do not have a tag, only a single constructor is allowed.
+    | UnboxedTagged     -- ^ values do have a tag, but closures not in the domain.
+    | Alias             -- ^ this type is isomorphic to an existing type
+-}
+
+-- | Record describing a data type.
+-- * is also a data type containing the type constructors, which are unboxed, yet tagged.
+
+
+data Constructor = Constructor {
+    conName :: Name,             -- name of constructor
+    conType :: E,                -- type of constructor
+    conExpr :: E,                -- expression which constructs this value
+    conSlots :: [E],             -- slots
+    conDeriving :: [Name],       -- classes this type derives
+    conClosures :: Bool,         -- does the domain contain closures?
+    conAlias :: Bool,            -- 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.
+    conChildren :: Maybe [Name]  -- if nothing, then type is abstract
+    } deriving(Show)
+    {-! derive: GhcBinary !-}
+
+newtype DataTable = DataTable {
+    constructorMap :: (Map Name Constructor)
+    }
+    deriving(Binary,Monoid,HasSize)
+
+getConstructor :: Monad m => Name -> DataTable -> m Constructor
+getConstructor n (DataTable map) = case Map.lookup n map of
+    Just x -> return x
+    Nothing -> fail $ "getConstructor: " ++ show n
+
+
+tunboxedtuple n = [typeCons,dataCons] where
+        dataCons = Constructor {
+            conName = dc,
+            conType = tipe,
+            conSlots = [],
+            conDeriving = [],
+            conExpr = Unknown, -- error "expr" ELam (tVr 2 rt) (ELit (LitCons dc [EVar (tVr 2 rt)] tipe)),
+            conClosures = False,
+            conAlias = False,
+            conInhabits = tc,
+            conChildren = Nothing
+           }
+        typeCons = Constructor {
+            conName = tc,
+            conType = eStar,
+            conSlots = [],
+            conDeriving = [],
+            conExpr = tipe,
+            conClosures = False,
+            conAlias = False,
+            conInhabits = tStar,
+            conChildren = Just [dc]
+           }
+
+        dc = unboxedNameTuple DataConstructor n
+        tc = unboxedNameTuple TypeConstructor n
+        tipe = ELit (LitCons tc [] eStar)
+
+
+tabsurd = Constructor {
+            conName = toName TypeConstructor "Absurd#",
+            conType = eStar,
+            conSlots = [],
+            conDeriving = [],
+            conExpr = tAbsurd eStar,
+            conClosures = False,
+            conAlias = False,
+            conInhabits = tStar,
+            conChildren = Nothing
+    }
+
+tarrow = Constructor {
+            conName = toName TypeConstructor ("Prelude","->"),
+            conType = EPi (tVr 0 eStar) (EPi (tVr 0 eStar) eStar),
+            conSlots = [eStar,eStar],
+            conDeriving = [],
+            conExpr = ELam (tVr 2 eStar) (ELam (tVr 4 eStar) (EPi (tVr 0 (EVar $ tVr 2 eStar)) (EVar $ tVr 4 eStar))),
+            conClosures = True,
+            conAlias = False,
+            conInhabits = tStar,
+            conChildren = Nothing
+        }
+
+
+primitiveTable = concatMap f allCTypes ++ map g (snub $ snds allCTypes) where
+    g n = Constructor {
+        conName = rn,
+        conType = eStar,
+        conSlots = [],
+        conDeriving = [],
+        conExpr = ELit (LitCons rn [] eStar),
+        conClosures = False,
+        conAlias = False,
+        conInhabits = tStar,
+        conChildren = Nothing
+       } where rn = toName RawType n
+    f (x,y) | x /= "Prelude.()" = [typeCons,dataCons] where
+        dataCons = Constructor {
+            conName = dc,
+            conType = tipe,
+            conSlots = [rt],
+            conDeriving = [],
+            conExpr = ELam (tVr 2 rt) (ELit (LitCons dc [EVar (tVr 2 rt)] tipe)),
+            conClosures = True,
+            conAlias = False,
+            conInhabits = tc,
+            conChildren = Nothing
+           }
+        typeCons = Constructor {
+            conName = tc,
+            conType = eStar,
+            conSlots = [],
+            conDeriving = [],
+            conExpr = tipe,
+            conClosures = True,
+            conAlias = False,
+            conInhabits = tStar,
+            conChildren = Just [dc]
+           }
+
+        rn = toName RawType y
+        rt = ELit (LitCons rn [] eStar)
+        dc = parseName DataConstructor x
+        tc = parseName TypeConstructor x
+        tipe = ELit (LitCons tc [] eStar)
+    f _ = []
+
+-- | determine if types are the same expanding newtypes and
+typesCompatable :: Monad m => DataTable -> E -> E -> m ()
+typesCompatable dataTable a b = go a b where
+    go :: Monad m => E -> E -> m ()
+    go a b = g' [] [] a b
+    g' xs ys a b = g a b where
+        g (ELit (LitCons n xs t)) (ELit (LitCons n' xs' t')) | n == n' = do
+            go t t'
+            when (not $ sameShape1 xs xs') $ fail "Arg lists don't match"
+            zipWithM_ go xs xs'
+        g (ESort a) (ESort b) = when (a /= b) $ fail "Sorts don't match"
+        g (EVar a) (EVar b) = when (a /= b) $ fail "Vars don't match"
+        g (EAp a b) (EAp a' b') = do
+            go a a'
+            go b b'
+        g x@(EPi {}) y@(EPi {}) = do
+            let EPi (TVr { tvrType =  a}) b = allShadow x
+                EPi (TVr { tvrType =  a'}) b' = allShadow y
+            go a a'
+            go b b'
+        g (EPi (TVr { tvrIdent = 0, tvrType =  a}) b) (ELit (LitCons n [a',b'] t)) | conName tarrow == n, t == eStar = do go a a'; go b b'
+        g (ELit (LitCons n [a',b'] t)) (EPi (TVr { tvrIdent = 0, tvrType =  a}) b) | conName tarrow == n, t == eStar = do go a a'; go b b'
+        g x@(ELam {}) y@(ELam {}) = do
+            let ELam (TVr { tvrType = a}) b = allShadow x
+                ELam (TVr { tvrType =  a'}) b' = allShadow y
+            go a a'
+            go b b'
+        g a b = case f xs ys a b of
+            Right () -> return ()
+            Left s' -> case f ys xs b a of
+                Right () -> return ()
+                Left s -> fail (s ++ ":" ++ s')
+    f :: Monad m => [Name] -> [Name] -> E -> E -> m ()
+    f xs ys (ELit (LitCons n _ _)) _ | n `elem` xs = fail "Loop detected"
+    f xs ys a@(ELit (LitCons n _ _)) b | Just x <- followAlias dataTable a = g' (n:xs) ys x b
+    f _ _ _ _ = fail "Types don't match"
+
+
+lookupCType dataTable e = case followAliases dataTable e of
+    ELit (LitCons c [] _) | Just pt <- Prelude.lookup (show c) allCTypes -> return (c,pt)
+    _ -> fail $ "lookupCType: " ++ show e
+
+lookupCType' dataTable e = case followAliases dataTable e of
+    ELit (LitCons c [] _)
+        | Just Constructor { conChildren = Just [cn] }  <- getConstructor c dataTable,
+          Just Constructor { conSlots = [st@(ELit (LitCons n [] _))] } <- getConstructor cn dataTable
+            -> return (cn,st,show n)
+    ELit (LitCons c [] _) | Just cn  <- getConstructor c dataTable -> fail $ "lookupCType: " ++ show cn
+    _ -> fail $ "lookupCType: " ++ show e
+
+followAlias :: Monad m => DataTable -> E -> m E
+followAlias dataTable (ELit (LitCons c ts e))
+    | Just con <- jcon, Just [cn] <- jcn, conAlias ccon  = return ans where
+        jcn@(~(Just [cn])) = conChildren con
+        Identity ccon = getConstructor cn dataTable
+        jcon@(~(Just con)) = getConstructor c dataTable
+        [sl] = conSlots ccon
+        ans = doSubst False False (Map.fromList $ zip [2..] (map Just ts)) sl
+followAlias _ e = fail "followAlias: not an alias"
+
+followAliases :: DataTable -> E -> E
+followAliases dataTable (ELit (LitCons c ts e))
+    | Just con <- jcon, Just [cn] <- jcn, conAlias ccon  = followAliases dataTable ans where
+        jcn@(~(Just [cn])) = conChildren con
+        Identity ccon = getConstructor cn dataTable
+        jcon@(~(Just con)) = getConstructor c dataTable
+        [sl] = conSlots ccon
+        ans = doSubst False False (Map.fromList $ zip [2..] (map Just ts)) sl
+followAliases _ e = e
+
+dataTablePrims =  Map.fromList [ (conName x,x) | x <- tabsurd:tarrow:primitiveTable ]
+
+toDataTable :: (Map Name Kind) -> (Map Name Scheme) -> [HsDecl] -> DataTable
+toDataTable km cm ds = DataTable $ Map.union dataTablePrims  (Map.fromList [ (conName x,x) | x <- ds' ])  where
+    ds' = Seq.toList $ execWriter (mapM_ f ds)
+    f decl@HsNewTypeDecl {  hsDeclCon = c } = dt decl True  [c]
+    f decl@HsDataDecl {  hsDeclCons = cs } = dt decl False  cs
+    f _ = return ()
+    dt decl alias cs = do
+        cs' <- mapM dc cs
+        tell $ Seq.singleton d { conChildren = Just cs' }
+        where
+        as = hsDeclArgs decl
+        name = hsDeclName decl
+        d = Constructor {
+            conName = nm,
+            conType = kind $ runIdentity (Map.lookup nm km),
+            conSlots = map tvrType ts,
+            conExpr = foldr ($) (ELit (LitCons  nm (map EVar ts) rt)) (map ELam ts),
+            conClosures = True,
+            conDeriving = [ toName ClassName n | n <- hsDeclDerives decl],
+            conAlias = False,
+            conInhabits = tStar,
+            conChildren = undefined
+            }
+        (rt,ts') = fromPi (conType d)
+        ts = [ tvr { tvrIdent = x } | tvr  <- ts' | x <- [2,4..] ]
+        nm = toName Name.TypeConstructor name
+        dc x = let z = dc' x in tell (Seq.singleton z) >> return (conName z)
+        dc' x = Constructor {
+            conName = nm',
+            conType = ty',
+            conSlots = map (subst . tvrType) ts,  -- XXX TODO fix this mapping
+            conExpr = foldr ($) (ELit (LitCons  nm' (map EVar ts) rt)) (map ELam ts),
+            conInhabits = nm,
+            conDeriving = [],
+            conAlias = alias,
+            conClosures = False,
+            conChildren = Nothing
+            } where
+            nm' =  toName Name.DataConstructor (hsConDeclName x)
+            (rt@(ELit (LitCons _ xs _)) ,ts') = fromPi ty'
+            subst = substMap $ IM.fromList [ (tvrIdent tv ,EVar $ tv { tvrIdent = p }) | EVar tv <- xs | p <- [2,4..] ]
+            ts = [ tvr { tvrIdent =  (x)}   | tvr <- ts' | x <- [2,4..] ]
+            ty' = tipe ty
+            (Forall _ (_ :=> ty)) = runIdentity $ Map.lookup nm' cm
+
+
+
+getConstructorArities  :: DataTable -> [(Name,Int)]
+getConstructorArities (DataTable dt) = [ (n,length $ conSlots c) | (n,c) <- Map.toList dt]
+
+
+
+
+slotTypes ::
+    DataTable -- ^ table of data constructors
+    -> Name   -- ^ name of constructor
+    -> E      -- ^ type of value
+    -> [E]    -- ^ type of each slot
+slotTypes wdt@(DataTable dt) n (ELit (LitCons pn xs _))
+    | pn == conName pc = [sub x | x <- conSlots mc ]
+    where
+    Identity mc = getConstructor n wdt
+    Just pc = Map.lookup (conInhabits mc) dt
+    sub = substMap $ IM.fromList [ (i,sl) | sl <- xs | i <- [2,4..] ]
+slotTypes wdt n e | Just fa <- followAlias wdt e  = slotTypes wdt n fa
+slotTypes _ _ e = error $ "slotTypes:" ++ show e
+
+showDataTable (DataTable mp) = vcat xs where
+    c  const = vcat [t,e,cl,cs,al,ih,ch] where
+        t = text "::" <+> ePretty conType
+        e = text "=" <+> ePretty conExpr
+        cl = text "closures:" <+> tshow conClosures
+        cs = text "slots:" <+> tupled (map ePretty (conSlots const))
+        al = text "alias:" <+> tshow conAlias
+        ih = text "inhabits:" <+> tshow conInhabits
+        ch = text "children:" <+> tshow conChildren
+        Constructor {
+            conName = conName, conType = conType, conExpr = conExpr, conClosures = conClosures,
+                conAlias  = conAlias, conInhabits = conInhabits, conChildren = conChildren
+                    } = const
+    xs =  [ text x <+> hang 0  (c y) | (x,y) <- ds]
+    ds = sortBy (\(x,_) (y,_) -> compare x y) [ (show x,y)  | (x,y) <-  Map.toList mp]
+
+
+getSiblings :: DataTable -> Name -> Maybe [Name]
+getSiblings (DataTable mp) n
+    | Just c <- Map.lookup n mp, Just s <- Map.lookup (conInhabits c) mp = conChildren s
+    | otherwise =  Nothing
+--    | otherwise = error $ "getSiblings: " ++ show n ++ show (Map.keys mp) ++ show (n `elem` (Map.keys mp))
+
+
+-- These will eventually be described in the Prelude directly as boxed versions of the
+-- underlying unboxed type.
+--
+-- TODO float, double, integer
+
+--builtinTypes = [ btype tInt, btype tChar ]
+
+--btype x = Data {
+--    dtName =  x,
+--    dtType = tStar,
+--    dtArgs = [],
+--    dtAlias = False,
+--    dtCLosures = True,
+--    dtCons = Nothing
+--}
addfile ./DerivingDrift/DataP.hs
hunk ./DerivingDrift/DataP.hs 1
+-- 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 (Statement(..),Data(..),Type(..),Body(..),
+		Name,Var,Class,Constructor)
+where 
+
+import Char
+import 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
+----------------------------------------------------------------------------
+
+---------------------------------------------------------------------------
+data Type	= Arrow Type Type -- fn
+		| LApply Type [Type] -- proper application
+		| Var String	  -- variable
+		| Con String      -- constructor
+		| Tuple [Type]	  -- tuple
+		| List Type	  -- list
+			deriving (Eq,Show)
+
+
addfile ./DerivingDrift/Drift.hs
hunk ./DerivingDrift/Drift.hs 1
+module DerivingDrift.Drift(driftDerive) where
+
+
+import HsSyn
+import DerivingDrift.DataP
+import DerivingDrift.StandardRules
+import qualified Data.Map as Map
+import FrontEnd.HsParser
+import FrontEnd.ParseMonad
+import Text.PrettyPrint.HughesPJ(render)
+--import DerivingDrift.Pretty(render)
+import CharIO
+import Char
+import qualified FlagDump as FD
+import Options
+
+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 ]
+
+driftDerive' :: Monad m => HsDecl -> m String
+driftDerive' (HsDataDecl sloc cntxt name args condecls derives) = do
+        let d =  toData  name args condecls derives 
+        xs <- return $  map (derive d . show) derives 
+        return $ unlines xs
+driftDerive' (HsNewTypeDecl sloc cntxt name args condecl derives) = do
+        let d =  toData  name args [condecl] derives 
+        xs <- return $ map (derive d . show) 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 }
+
+rulesMap = Map.fromList [ (t,f) | (t,f,_,_,_) <- standardRules]
+
+derive d wh | Just fn <- Map.lookup wh rulesMap = render $ fn d 
+
+
addfile ./DerivingDrift/RuleFunctorM.hs
hunk ./DerivingDrift/RuleFunctorM.hs 1
+-- stub module to add your own rules.
+module RuleFunctorM (rules) where
+
+import List 
+import DerivingDrift.RuleUtils 
+
+rules = [
+    ("FunctorM", userRuleFunctorM, "Generics", "derive reasonable fmapM implementation", Nothing),
+    ("RMapM", userRuleRMapM, "Generics", "derive reasonable rmapM implementation", Nothing)
+    ]
+
+{- datatype that rules manipulate :-
+
+
+data Data = D {	name :: Name,			 -- type's name
+			constraints :: [(Class,Var)], 
+			vars :: [Var],		 -- Parameters
+			body :: [Body],
+			derives :: [Class],	 -- derived classes
+			statement :: Statement}  -- type of statement
+	   | Directive				 --|
+	   | TypeName Name			 --| used by derive (ignore)
+		deriving (Eq,Show) 
+
+data Body = Body { constructor :: Constructor,
+		    labels :: [Name], -- [] for a non-record datatype.
+		    types :: [Type]} deriving (Eq,Show) 
+
+data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
+
+type Name = String
+type Var = String
+type Class = String
+type Constructor = String
+
+type Rule = (Tag, Data->Doc)
+
+-}
+
+{-
+
+-- useful helper things
+namesupply   = [text [x,y] | x <- ['a' .. 'z'], 
+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
+mknss []     _  = []
+mknss (c:cs) ns =
+  let (thisns,rest) = splitAt (length (types c)) ns
+  in thisns: mknss cs rest 
+
+mkpattern :: Constructor -> [a] -> [Doc] -> Doc
+mkpattern c l ns =
+  if null l then text c
+  else parens (hsep (text c : take (length l) ns))
+
+instanceheader cls dat =
+  let fv     = vars dat
+      tycon  = name dat
+      ctx    = map (\v-> text cls <+> text v)
+      parenSpace = parens . hcat . sepWith space
+  in
+  hsep [ text "instance"
+       , opt fv (\v -> parenList (ctx v) <+> text "=>")
+       , text cls
+       , opt1 (texts (tycon: fv)) parenSpace id
+       , text "where"
+       ]
+
+-}
+
+
+
+-- begin here for Binary derivation
+
+
+userRuleFunctorM D{name = name, vars = [] } = text "--" <+> text name <> text ": Cannot derive FunctorM without type variables"
+userRuleFunctorM D{name = name, vars = vars, body=body } = ins where
+    (tt:rt') = reverse vars
+    rt = reverse rt'
+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))
+    ins = text "instance" <+> text "FunctorM" <+> fn <+> text "where" $$ block fs
+    fs = map f' $ body 
+    f' Body{constructor=constructor, types=types} = text "fmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where
+        vnt = varNames types
+        g (t,n) | not (has t) = empty
+        g (Var t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon
+        g (List (Var t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon
+        g (List t,n)  = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon  where 
+            lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x
+        g (LApply t [],n) = g (t,n)
+        g (LApply t ts,n) | last ts == Var tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon
+        g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon  
+        g _ = empty
+    has (Var t) | t == tt = True
+    has (List t) = has t
+    has (Arrow a b) = has a || has b
+    has (LApply t ts) = any has (t:ts)
+    has (Tuple ts) = any has (ts)
+    has _ = False
+
+userRuleRMapM D{name = name, vars = vars, body=body } = ins where
+    --(tt:rt') = reverse vars
+    tt = if null vars then Con name else LApply (Con name) (map Var vars) 
+    rt = vars
+    fn = if null rt then text name else parens (text name <+> hsep (map text rt))
+    ins = text "instance" <+> text "RMapM" <+> fn <+> text "where" $$ block fs
+    fs = map f' $ body 
+    f' Body{constructor=constructor, types=types} = text "rmapM" <+> text "f" <+> pattern constructor types <+> equals <+> text "do" <+> hcat (map g (zip types vnt)) <+> text "return $" <+> text constructor <+> hsep vnt where
+        vnt = varNames types
+        g (t,n) | not (has t) = empty
+        g ( t,n) | t == tt = n <+> lArrow <+> text "f" <+> n <> semicolon
+        g (List (t),n) | t == tt = n <+> lArrow <+> text "mapM" <+> f <+> n <> semicolon
+        g (List t,n)  = n <+> lArrow <+> text "mapM" <+> lf t <+> n <> semicolon  where 
+            lf t = parens $ text "\\x ->" <+> text "do" <+> g (t,x) <+> text "return" <+> x
+        g (LApply t [],n) = g (t,n)
+        g (LApply t ts,n) | last ts ==  tt = n <+> lArrow <+> text "fmapM" <+> f <+> n <> semicolon
+        g (Tuple ts,n) = n <+> lArrow <+> (parens $ text "do" <+> tuple (varNames ts) <+> lArrow <+> text "return" <+> n <> semicolon  <+> hcat (map g (zip ts (varNames ts))) <> text "return" <+> tuple (varNames ts)) <> semicolon  
+        g _ = empty
+    has t | t == tt = True
+    has (List t) = has t
+    has (Arrow a b) = has a || has b
+    has (LApply t ts) = any has (t:ts)
+    has (Tuple ts) = any has (ts)
+    has _ = False
+
addfile ./DerivingDrift/RuleMonoid.hs
hunk ./DerivingDrift/RuleMonoid.hs 1
+-- stub module to add your own rules.
+module RuleMonoid (rules) where
+
+import List 
+import DerivingDrift.RuleUtils 
+
+rules = [
+    ("Monoid", userRuleMonoid, "Generics", "derive reasonable Data.Monoid implementation", Nothing)
+    ]
+
+{- datatype that rules manipulate :-
+
+
+data Data = D {	name :: Name,			 -- type's name
+			constraints :: [(Class,Var)], 
+			vars :: [Var],		 -- Parameters
+			body :: [Body],
+			derives :: [Class],	 -- derived classes
+			statement :: Statement}  -- type of statement
+	   | Directive				 --|
+	   | TypeName Name			 --| used by derive (ignore)
+		deriving (Eq,Show) 
+
+data Body = Body { constructor :: Constructor,
+		    labels :: [Name], -- [] for a non-record datatype.
+		    types :: [Type]} deriving (Eq,Show) 
+
+data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
+
+type Name = String
+type Var = String
+type Class = String
+type Constructor = String
+
+type Rule = (Tag, Data->Doc)
+
+-}
+
+
+-- useful helper things
+
+mkpattern :: Constructor -> [Doc] -> Doc
+mkpattern c ns =
+  if null ns then text c
+  else parens (hsep (text c :  ns))
+
+instanceheader cls dat =
+  let fv     = vars dat
+      tycon  = name dat
+      ctx    = map (\v-> text cls <+> text v)
+      parenSpace = parens . hcat . sepWith space
+  in
+  hsep [ text "instance"
+       , opt fv (\v -> parenList (ctx v) <+> text "=>")
+       , text cls
+       , opt1 (texts (tycon: fv)) parenSpace id
+       , text "where"
+       ]
+
+
+
+
+-- begin here for Binary derivation
+
+
+userRuleMonoid dat@D{name = name, vars = vars, body=[body] } = ins where
+    ins = instanceheader "Monoid" dat $$ 
+        block [me, ma]
+    me, ma :: Doc
+    me = text "mempty" <+> equals <+> text (constructor body) <+> hsep (replicate lt (text "mempty"))     
+    ma = text "mappend" <+> mkpattern c (varNames ty) <+> mkpattern c (varNames' ty) <+> equals <+> text c <+> hcat (zipWith f (varNames ty) (varNames' ty))
+    f a b = parens $ text "mappend"  <+> a <+> b
+    c = constructor body
+    ty = types body
+    lt = length (types body)
+userRuleMonoid D{name = name } = text "--" <+> text name <> text ": Cannot derive Monoid from type"
+
+
addfile ./DerivingDrift/RuleUtility.hs
hunk ./DerivingDrift/RuleUtility.hs 1
+module DerivingDrift.RuleUtility(rules) where
+import DerivingDrift.RuleUtils
+import List 
+import GenUtil
+
+rules :: [RuleDef]
+rules = [("Query",queryGen, "Utility", "provide a QueryFoo class with 'is', 'has', 'from', and 'get' routines", Nothing) ]
+
+
+queryGen :: Data -> Doc
+queryGen d@D{name = name} = cls $$ text "" $$ ins where
+    cls = text "class" <+> text className <+> typeName <+> cargs <+> text "where" $$ block fs 
+    ot a b = a <+> text "::" <+> b
+    cargs = if null $ vars d then empty else dargs <+> text "|" <+> typeName <+> text "->" <+> dargs 
+    dargs =  hsep (map text $ vars d) 
+    className = "Query" ++ name
+    typeName = text "_x"
+    fs = (map is (body d) )
+    is Body{constructor = constructor, types = types} = fn $$ dfn $$ ffn where 
+        fnName = text $ "is" ++ constructor
+        fromName = "from" ++ constructor  
+        fn = ot fnName $  typeName <+> rArrow <+> text "Bool"   
+        dfn = fnName <+> x <+> text "=" <+> text "isJust" <+> parens (text fromName <+> x)
+        ffn = ot (text fromName) $ text "Monad _m =>" <+> typeName <+> rArrow <+> text "_m" <+> tuple (map prettyType types) 
+
+    ins = text "instance" <+> text className <+> parens (text name <+> dargs) <+> dargs <+> text "where" $$ block fromInsts
+    fromInsts = map fi (body d)
+    fi Body{constructor = constructor, types = types} = fn $$ dfn where 
+        fromName = "from" ++ constructor  
+        fn = text fromName <+> pattern constructor types <+> text "=" <+> text "return" <+> tuple (varNames types)
+        dfn = text fromName <+> blank <+> equals <+> text "fail" <+> tshow fromName
+
addfile ./DerivingDrift/RuleUtils.hs
hunk ./DerivingDrift/RuleUtils.hs 1
+-- utilities for writing new rules.
+
+module DerivingDrift.RuleUtils (module Text.PrettyPrint.HughesPJ,module DerivingDrift.RuleUtils, module DerivingDrift.DataP)where
+
+--import DerivingDrift.Pretty
+import Text.PrettyPrint.HughesPJ
+import DerivingDrift.DataP (Statement(..),Data(..),Type(..),Name,Var,Class,
+		Body(..),Constructor)
+
+-- Rule Declarations 
+
+type Tag = String
+type Rule = (Tag,Data -> Doc)
+-- Rule (name, rule, category, helpline, helptext)
+type RuleDef = (Tag, Data -> Doc, String, String, Maybe String)
+
+x = text "x"
+f = text "f"
+
+rArrow = text "->"
+lArrow = text "<-"
+--equals = text "="
+blank = text "_"
+semicolon = char ';'
+
+
+prettyType :: Type -> Doc
+--prettyType (Apply t1 t2) = parens (prettyType t1 <+> prettyType t2)
+prettyType (Arrow x y) = parens (prettyType x <+> text "->" <+> prettyType y)
+prettyType (List x) = brackets (prettyType x)
+prettyType (Tuple xs) = tuple (map prettyType xs)
+prettyType (Var s) = text s
+prettyType (Con s) = text s
+prettyType (LApply t ts) = prettyType t <+> hsep (map prettyType ts)
+
+-- 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)
addfile ./DerivingDrift/StandardRules.hs
hunk ./DerivingDrift/StandardRules.hs 1
+module DerivingDrift.StandardRules (standardRules) where
+
+import DerivingDrift.RuleUtils
+import List 
+import GenUtil
+
+tshow = text . show
+
+--- Add Rules Below Here ----------------------------------------------------
+
+standardRules :: [RuleDef]
+standardRules = [("test",dattest, "Utility", "output raw data for testing", Nothing),
+		  ("update",updatefn, "Utility","for label 'foo' provides 'foo_u' to update it and foo_s to set it", Nothing ),
+		  ("is",isfn, "Utility", "provides isFoo for each constructor", Nothing),
+		  ("get",getfn, "Utility", "for label 'foo' provide foo_g to get it", Nothing),
+	          ("from",fromfn, "Utility", "provides fromFoo for each constructor", Nothing),
+		  ("has",hasfn, "Utility", "hasfoo for record types", Nothing),
+		  ("un",unfn, "Utility", "provides unFoo for unary constructors", Nothing),
+		  ("NFData",nffn, "General","provides 'rnf' to reduce to normal form (deepSeq)", Nothing ),
+		  ("Eq",eqfn, "Prelude","", Nothing),
+		  ("Ord",ordfn, "Prelude", "", Nothing),
+		  ("Enum",enumfn, "Prelude", "", Nothing),
+		  ("Show",showfn, "Prelude", "", Nothing),
+		  ("Read",readfn, "Prelude", "", Nothing),
+		  ("Bounded",boundedfn, "Prelude", "", Nothing)]
+
+-----------------------------------------------------------------------------
+-- NFData - This class provides 'rnf' to reduce to normal form.
+-- This has a default for non-constructed datatypes
+-- Assume that base cases have been defined for lists, functions, and
+-- (arbitrary) tuples - makeRnf produces a function which applies rnf to
+-- each of the combined types in each constructor of the datatype. (If
+-- this isn't very clear, just look at the code to figure out what happens)
+
+nffn = instanceSkeleton "NFData" [(makeRnf,empty)]
+
+makeRnf :: IFunction
+makeRnf (Body{constructor=constructor,types=types})
+	| null types = text "rnf" <+> 
+		fsep [pattern constructor [],equals,text "()"]
+	| otherwise = let 
+   vars = varNames types
+   head = [pattern constructor vars, equals] 
+   body =  sepWith (text "`seq`") . map (text "rnf" <+>) $ vars
+       in  text "rnf" <+> fsep (head ++  body)
+
+
+-----------------------------------------------------------------------------
+-- Forming 'update' functions for each label in a record
+-- 
+-- for a datatype G, where label has type G -> a
+-- the corresponding update fn has type (a -> a) -> G -> G 
+-- The update fn has the same name as the label with _u appended
+
+-- an example of what we want to generate 
+-- 	--> foo_u f d{foo}=d{foo = f foo}
+-- 
+-- labels can be common to more than one constructor in a type. -- this
+-- is a problem, and the reason why a sort is used.
+
+updatefn :: Data -> Doc
+updatefn d@(D{body=body,name=name})
+	| hasRecord d = vcat (updates ++ sets)
+	| otherwise = commentLine $ 
+	text "Warning - can't derive `update' functions for non-record type: " 
+	<+> text name 
+	where 
+    nc = length body
+    labs = gf $ sort . concatMap f $ body
+    updates = map genup labs --  $$  hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x']
+    sets = map genset . nub . map fst $ labs 
+    f :: Body -> [(Name,Constructor)] 
+    f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor)
+    gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts))
+
+    genup :: (Name,[Constructor]) -> Doc
+    genup (n,cs) = vcat (map up cs) $$ up' where
+        up c = hsep [text (n ++ "_u") , char 'f' 
+            , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x") 
+            , equals , char 'r' <> braces (hsep [text n, text "= f x"])] 
+        up' | nc > length cs = hsep [text (n ++ "_u"), char '_', char 'x', equals, char 'x']
+            | otherwise =  empty
+
+    -- while we're at it, may as well define a set function too...
+    genset :: Name -> Doc
+    genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"] 
+
+getfn :: Data -> Doc
+getfn d@(D{body=body,name=name})
+	| hasRecord d = vcat (updates ++ sets)
+	| otherwise = commentLine $ 
+	text "Warning - can't derive `get' functions for non-record type: " 
+	<+> text name 
+	where 
+    nc = length body
+    labs = gf $ sort . concatMap f $ body
+    updates = map genup labs 
+    sets = map genset . nub . map fst $ labs 
+    f :: Body -> [(Name,Constructor)] 
+    f (Body{constructor=constructor,labels=labels}) = zip (filter (not . null) labels ) (repeat constructor)
+    gf ts = map (\ts -> (fst (head ts), snds ts)) (groupBy (\(a,_) (b,_) -> a == b) (sort ts))
+
+    genup :: (Name,[Constructor]) -> Doc
+    genup (n,cs) = vcat (map up cs) $$ up' where
+        fn = n ++ "_g"
+        up c = hsep [text fn 
+            , char 'r' <> char '@' <> text c <> braces (text n <+> text " = x") 
+            , equals , text "return x"] 
+        up' | nc > length cs = hsep [text fn, char '_',  equals, text "fail", tshow fn]
+            | otherwise =  empty
+
+    -- while we're at it, may as well define a set function too...
+    genset :: Name -> Doc
+    genset n = hsep [text (n ++ "_s v = "), text (n ++ "_u"), text " (const v)"] 
+
+----------------------------------------------------------------------
+-- Similar rules to provide predicates for the presence of a constructor / label
+
+isfn :: Data -> Doc
+isfn (D{body=body}) =  vcat (map is body)
+	where	
+	is Body{constructor=constructor,types=types} = let 
+		fnName = text ("is" ++ constructor)
+		fn = fnName <+> 
+			hsep [pattern_ constructor types,text "=",text "True"]
+		defaultFn = fnName <+> hsep (texts ["_","=","False"])
+		in fn $$ defaultFn
+
+fromfn :: Data -> Doc
+fromfn (D{body=body}) =  vcat (map from body) where	
+    from Body{constructor=constructor,types=types} = fn $$ defaultFn where 
+            fnName = ("from" ++ constructor)
+            fnName' = text fnName
+            fn = fnName' <+> 
+                    hsep [pattern constructor types,text "=",text "return", tuple (varNames types) ]
+            defaultFn = fnName' <+> hsep (texts ["_","=","fail",show fnName ])
+
+hasfn :: Data -> Doc
+hasfn d@(D{body=body,name=name})
+	| hasRecord d = vcat [has l b | l <- labs, b <- body]
+	| otherwise = commentLine $ 
+	    text "Warning - can't derive `has' functions for non-record type:"
+	    <+> text name
+	where     
+	has lab Body{constructor=constructor,labels=labels} = let
+		bool = text . show $ lab `elem` labels
+		pattern = text (constructor ++ "{}")
+		fnName = text ( "has" ++ lab)
+		in fsep[fnName, pattern, text "=", bool]     	    
+	labs = nub . concatMap (labels) $  body       
+		       
+
+-- Function to make using newtypes a bit nicer.
+-- for newtype N = T a , unN :: T -> a 
+
+unfn :: Data -> Doc
+unfn (D{body=body,name=name,statement=statement}) | statement == DataStmt 
+	= commentLine 
+	  $ text "Warning - can't derive 'un' function for data declaration " 
+	  <+> text name
+			      | otherwise
+	= let fnName = text ("un" ++ name)
+	      b = head body
+	      pattern = parens $ text (constructor b) <+> text "a"
+	      in fsep [fnName,pattern, equals, text "a"] 
+
+
+-----------------------------------------------------------------------------
+-- A test rule for newtypes datastructures - just outputs
+-- parsed information. Can put {-! global : Test !-} in an input file, and output
+-- from the entire file should be generated.
+
+
+dattest d =  commentBlock . vcat $ 
+           [text (name d)
+		, fsep . texts . map show $ constraints d
+		, fsep . texts . map show $ vars d
+	        , fsep . texts . map show $ body d
+		, fsep . texts . map show $ derives d
+		, text .  show $ statement d]
+
+
+------------------------------------------------------------------------------
+-- 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 ..]
+		, c' <- zip (body d) [1 ..]]
+   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", "y"]
+		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 ..])
+	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 ..])
+	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
+
addfile ./DerivingDrift/UserRuleBinary.hs
hunk ./DerivingDrift/UserRuleBinary.hs 1
+-- stub module to add your own rules.
+module UserRuleBinary (userRulesBinary) where
+
+import List (nub,intersperse)
+import DerivingDrift.RuleUtils -- useful to have a look at this too
+
+userRulesBinary = [
+    ("Binary", userRuleBinary, "Binary", "efficient binary encoding of terms", Nothing)
+    ]
+
+{- datatype that rules manipulate :-
+
+
+data Data = D {	name :: Name,			 -- type's name
+			constraints :: [(Class,Var)], 
+			vars :: [Var],		 -- Parameters
+			body :: [Body],
+			derives :: [Class],	 -- derived classes
+			statement :: Statement}  -- type of statement
+	   | Directive				 --|
+	   | TypeName Name			 --| used by derive (ignore)
+		deriving (Eq,Show) 
+
+data Body = Body { constructor :: Constructor,
+		    labels :: [Name], -- [] for a non-record datatype.
+		    types :: [Type]} deriving (Eq,Show) 
+
+data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
+
+type Name = String
+type Var = String
+type Class = String
+type Constructor = String
+
+type Rule = (Tag, Data->Doc)
+
+-}
+
+
+-- useful helper things
+namesupply   = [text [x,y] | x <- ['a' .. 'z'], 
+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
+mknss []     _  = []
+mknss (c:cs) ns =
+  let (thisns,rest) = splitAt (length (types c)) ns
+  in thisns: mknss cs rest 
+
+mkpattern :: Constructor -> [a] -> [Doc] -> Doc
+mkpattern c l ns =
+  if null l then text c
+  else parens (hsep (text c : take (length l) ns))
+
+instanceheader cls dat =
+  let fv     = vars dat
+      tycon  = name dat
+      ctx    = map (\v-> text cls <+> text v)
+      parenSpace = parens . hcat . sepWith space
+  in
+  hsep [ text "instance"
+       , opt fv (\v -> parenList (ctx v) <+> text "=>")
+       , text cls
+       , opt1 (texts (tycon: fv)) parenSpace id
+       , text "where"
+       ]
+
+
+
+
+-- begin here for Binary derivation
+
+
+userRuleBinary dat = 
+  let cs  = body dat
+      cvs = mknss cs namesupply
+      k   = (ceiling . logBase 2 . realToFrac . length) cs
+  in
+  instanceheader "Binary" dat $$
+  block (  zipWith3 (putfn k) [0..] cvs cs
+        ++ getfn k [0..] cvs cs
+        :  getFfn k [0..] cvs cs
+        :  zipWith (sizefn k) cvs cs
+        )
+
+putfn k n cv c =
+  text "put bh" <+> ppCons cv c <+> text "= do" $$
+  nest 8 (
+    text "pos <- putBits bh" <+> text (show k) <+> text (show n) $$
+    vcat (map (text "put bh" <+>) cv) $$
+    text "return pos"
+  )
+
+ppCons cv c = mkpattern (constructor c) (types c) cv
+
+getfn k ns cvs cs =
+  text "get bh = do" $$
+  nest 8 (
+    text "h <- getBits bh" <+> text (show k) $$
+    text "case h of" $$
+    nest 2 ( vcat $
+      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$
+                          nest 6 (
+                            vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
+                            text "return" <+> ppCons vs c
+                          ))
+               ns cvs cs
+    )
+  )
+
+getFfn k ns cvs cs =
+  text "getF bh p =" <+>
+  nest 8 (
+    text "let (h,p1) = getBitsF bh 1 p in" $$
+    text "case h of" $$
+    nest 2 ( vcat $
+      zipWith3 (\n vs c-> text (show n) <+> text "->" <+>
+                          parens (cons c <> text ",p1") <+>
+                          hsep (map (\_-> text "<< getF bh") vs))
+               ns cvs cs
+    )
+  )
+  where cons =  text . constructor
+
+sizefn k [] c =
+  text "sizeOf" <+> ppCons [] c <+> text "=" <+> text (show k)
+sizefn k cv c =
+  text "sizeOf" <+> ppCons cv c <+> text "=" <+> text (show k) <+> text "+" <+>
+  hsep (intersperse (text "+") (map (text "sizeOf" <+>) cv))
+
+
+-- end of binary derivation
+
addfile ./DerivingDrift/UserRuleGhcBinary.hs
hunk ./DerivingDrift/UserRuleGhcBinary.hs 1
+-- stub module to add your own rules.
+module UserRuleGhcBinary (userRulesGhcBinary) where
+
+import List (nub,intersperse)
+import DerivingDrift.RuleUtils -- useful to have a look at this too
+
+userRulesGhcBinary = [
+    ("GhcBinary", userRuleGhcBinary, "Binary", "byte sized binary encoding of terms", Nothing)
+    ]
+
+{- datatype that rules manipulate :-
+
+
+data Data = D {	name :: Name,			 -- type's name
+			constraints :: [(Class,Var)], 
+			vars :: [Var],		 -- Parameters
+			body :: [Body],
+			derives :: [Class],	 -- derived classes
+			statement :: Statement}  -- type of statement
+	   | Directive				 --|
+	   | TypeName Name			 --| used by derive (ignore)
+		deriving (Eq,Show) 
+
+data Body = Body { constructor :: Constructor,
+		    labels :: [Name], -- [] for a non-record datatype.
+		    types :: [Type]} deriving (Eq,Show) 
+
+data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
+
+type Name = String
+type Var = String
+type Class = String
+type Constructor = String
+
+type Rule = (Tag, Data->Doc)
+
+-}
+
+
+-- useful helper things
+namesupply   = [text [x,y] | x <- ['a' .. 'z'], 
+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
+mknss []     _  = []
+mknss (c:cs) ns =
+  let (thisns,rest) = splitAt (length (types c)) ns
+  in thisns: mknss cs rest 
+
+mkpattern :: Constructor -> [a] -> [Doc] -> Doc
+mkpattern c l ns =
+  if null l then text c
+  else parens (hsep (text c : take (length l) ns))
+
+instanceheader cls dat =
+  let fv     = vars dat
+      tycon  = name dat
+      ctx    = map (\v-> text cls <+> text v)
+      parenSpace = parens . hcat . sepWith space
+  in
+  hsep [ text "instance"
+       , opt fv (\v -> parenList (ctx v) <+> text "=>")
+       , text cls
+       , opt1 (texts (tycon: fv)) parenSpace id
+       , text "where"
+       ]
+
+
+
+
+-- begin here for Binary derivation
+
+
+userRuleGhcBinary dat = 
+  let cs  = body dat
+      cvs = mknss cs namesupply
+      --k   = (ceiling . logBase 256 . realToFrac . length) cs
+      k = length cs
+  in
+  instanceheader "Binary" dat $$
+  block (  zipWith3 (putfn k) [0..] cvs cs
+        ++ [getfn k [0..] cvs cs]
+        )
+
+putfn 1 _ [] c = 
+    text "put_ _" <+> ppCons [] c <+> text "= return ()"
+putfn 1 _ cv c = 
+  text "put_ bh" <+> ppCons cv c <+> text "= do" $$
+  nest 8 (
+    vcat (map (text "put_ bh" <+>) cv) 
+  )
+putfn _ n cv c =
+  text "put_ bh" <+> ppCons cv c <+> text "= do" $$
+  nest 8 (
+    text "putByte bh" <+> text (show n) $$
+    vcat (map (text "put_ bh" <+>) cv) -- $$
+    --text "return pos"
+  )
+
+ppCons cv c = mkpattern (constructor c) (types c) cv
+
+getfn _ _ [[]] [c] = 
+    text "return" <+> ppCons [] c
+getfn _ _ [vs] [c] = 
+  text "get bh = do" $$
+    vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
+    text "return" <+> ppCons vs c
+getfn _ ns cvs cs =
+  text "get bh = do" $$
+  nest 8 (
+    text "h <- getByte bh"  $$
+    text "case h of" $$
+    nest 2 ( vcat $
+      zipWith3 (\n vs c-> text (show n) <+> text "-> do" $$
+                          nest 6 (
+                            vcat (map (\v-> v <+> text "<-" <+> text "get bh") vs) $$
+                            text "return" <+> ppCons vs c
+                          ))
+               ns cvs cs
+    )
+  )
+
+
+
+-- end of binary derivation
+
addfile ./DerivingDrift/UserRuleXml.hs
hunk ./DerivingDrift/UserRuleXml.hs 1
+-- stub module to add your own rules.
+module UserRuleXml (userRulesXml) where
+
+import List (nub,sortBy)
+import DerivingDrift.RuleUtils -- useful to have a look at this too
+
+userRulesXml :: [RuleDef]
+userRulesXml = [("Haskell2Xml", userRuleXml, "Representation", "encode terms as XML", Nothing)]
+
+{- datatype that rules manipulate :-
+
+
+data Data = D {	name :: Name,			 -- type's name
+			constraints :: [(Class,Var)], 
+			vars :: [Var],		 -- Parameters
+			body :: [Body],
+			derives :: [Class],	 -- derived classes
+			statement :: Statement}  -- type of statement
+	   | Directive				 --|
+	   | TypeName Name			 --| used by derive (ignore)
+		deriving (Eq,Show) 
+
+data Body = Body { constructor :: Constructor,
+		    labels :: [Name], -- [] for a non-record datatype.
+		    types :: [Type]} deriving (Eq,Show) 
+
+data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
+
+type Name = String
+type Var = String
+type Class = String
+type Constructor = String
+
+type Rule = (Tag, Data->Doc)
+
+-}
+
+userRuleXml dat = 
+  let cs  = body dat
+      cvs = mknss cs namesupply
+  in
+  instanceheader "Haskell2Xml" dat $$
+  block (toHTfn cs cvs dat:
+         ( text "fromContents (CElem (Elem constr [] cs):etc)" $$
+           vcat (preorder cs (zipWith3 readsfn [0..] cvs cs))):
+         zipWith3 showsfn [0..] cvs cs)
+
+toHTfn cs cvs dat =
+  let typ  = name dat
+      fvs  = vars dat
+      pats = concat (zipWith mkpat cvs cs)
+  in
+  text "toHType v =" $$
+  nest 4 (
+    text "Defined" <+>
+    fsep [ text "\"" <> text typ <> text "\""
+         , bracketList (map text fvs)
+         , bracketList (zipWith toConstr cvs cs)
+         ]
+    ) $$
+  if null pats then empty
+  else nest 2 (text "where") $$
+       nest 4 (vcat (map (<+> text "= v") pats)) $$
+       nest 4 (vcat (map (simplest typ (zip cvs cs)) fvs))
+
+namesupply   = [text [x,y] | x <- ['a' .. 'z'], 
+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
+
+mknss []     _  = []
+mknss (c:cs) ns =
+  let (thisns,rest) = splitAt (length (types c)) ns
+  in thisns: mknss cs rest 
+
+mkpat ns c =
+  if null ns then []
+  else [mypattern (constructor c) (types c) ns]
+
+
+toConstr :: [Doc] -> Body -> Doc
+toConstr ns c =
+  let cn = constructor c
+      ts = types c
+      fvs = nub (concatMap deepvars ts)
+  in
+  text "Constr" <+>
+  fsep [ text "\"" <> text cn <> text "\""
+       , bracketList (map text fvs)
+       , bracketList (map (\v-> text "toHType" <+> v) ns)
+       ]
+
+  where
+
+    deepvars (Arrow t1 t2)  = []
+    --deepvars (Apply t1 t2)  = deepvars t1 ++ deepvars t2
+    deepvars (LApply c ts)  = concatMap deepvars ts
+    deepvars (Var s)        = [s]
+    deepvars (Con s)        = []
+    deepvars (Tuple ts)     = concatMap deepvars ts
+    deepvars (List t)       = deepvars t
+
+--first [] fv = error ("cannot locate free type variable "++fv)
+--first ((ns,c):cs) fv =
+--  let npats = [ (n,pat) | (n,t) <- zip ns (types c)
+--                        , (True,pat) <- [ find fv t ]
+--              ]
+--  in
+--  if null npats then
+--       first cs fv
+--  else let (n,pat) = head npats
+--       in parens pat <+> text "= toHType" <+> n
+--
+--  where
+--
+--    find :: String -> Type -> (Bool,Doc)
+--    find v (Arrow t1 t2)  = (False,error "can't ShowXML for arrow type")
+--    find v (Apply t1 t2)  = let (tf1,pat1) = find v t1
+--                                (tf2,pat2) = find v t2
+--                            in perhaps (tf1 || tf2)
+--                                       (pat1 <+> snd (perhaps tf2 pat2))
+--    find v (LApply c ts)  = let (_,cpat) = find v c
+--                                tfpats = map (find v) ts
+--                                (tfs,pats) = unzip tfpats
+--                            in perhaps (or tfs)
+--                                       (parens (cpat <+>
+--                                                bracketList (map (snd.uncurry perhaps) tfpats)))
+--    find v (Var s)        = perhaps (v==s) (text v)
+--    find v (Con s)        = (False, text "Defined" <+>
+--                                    text "\"" <> text s <> text "\"")
+--    find v (Tuple ts)     = let tfpats = map (find v) ts
+--                                (tfs,pats) = unzip tfpats
+--                            in perhaps (or tfs)
+--                                       (parens (text "Tuple" <+>
+--                                                bracketList (map (snd.uncurry perhaps) tfpats)))
+--    find v (List t)       = let (tf,pat) = find v t
+--                            in perhaps tf (parens (text "List" <+> pat))
+--    perhaps tf doc = if tf then (True,doc) else (False,text "_")
+
+simplest typ cs fv =
+  let npats = [ (depth,(n,pat)) | (ns,c) <- cs
+                                , (n,t) <- zip ns (types c)
+                                , (depth, pat) <- [ find fv t ]
+              ]
+      (_,(n,pat)) = foldl closest (Nothing,error "free tyvar not found") npats
+  in
+  parens pat <+> text "= toHType" <+> n
+
+  where
+
+    find :: String -> Type -> (Maybe Int,Doc)
+    find v (Arrow t1 t2)  = (Nothing,error "can't derive Haskell2XML for arrow type")
+--    find v (Apply t1 t2)  = let (d1,pat1) = find v t1
+--                                (d2,pat2) = find v t2
+--                            in perhaps (combine [d1,d2])
+--                                       (pat1 <+> snd (perhaps d2 pat2))
+    find v (LApply c ts)
+        | c == (Con typ)  = (Nothing, text "_")
+        | otherwise       = let (_,cpat)  = find v c
+                                dpats     = map (find v) ts
+                                (ds,pats) = unzip dpats
+                            in perhaps (combine ds)
+                                       (cpat <+>
+                                        bracketList (map (snd.uncurry perhaps) dpats) <+>
+                                        text "_")
+    find v (Var s)        = perhaps (if v==s then Just 0 else Nothing) (text v)
+    find v (Con s)        = (Nothing, text "Defined" <+>
+                                      text "\"" <> text s <> text "\"")
+    find v (Tuple ts)     = let dpats = map (find v) ts
+                                (ds,pats) = unzip dpats
+                            in perhaps (combine ds)
+                                       (text "Tuple" <+>
+                                        bracketList (map (snd.uncurry perhaps) dpats))
+    find v (List t)       = let (d,pat) = find v t
+                            in perhaps (inc d) (text "List" <+> parens pat)
+
+    perhaps Nothing doc   = (Nothing, text "_")
+    perhaps jn doc        = (jn,doc)
+    combine ds   = let js = [ n | (Just n) <- ds ]
+                   in if null js then Nothing else inc (Just (minimum js))
+    inc Nothing  = Nothing
+    inc (Just n) = Just (n+1)
+
+    closest :: (Maybe Int,a) -> (Maybe Int,a) -> (Maybe Int,a)
+    closest (Nothing,_)  b@(Just _,_) = b
+    closest a@(Just n,_) b@(Just m,_) | n< m  = a
+                                      | m<=n  = b
+    closest a b = a
+
+
+
+showsfn n ns cn =
+  let cons = constructor cn
+      typ  = types cn
+      sc   = parens (text "showConstr" <+> text (show n) <+>
+                     parens (text "toHType" <+> text "v"))
+      cfn []  = text "[]"
+      cfn [x] = parens (text "toContents" <+> x)
+      cfn xs  = parens (text "concat" <+> bracketList (map (text "toContents" <+>) xs))
+  in
+  text "toContents" <+>
+  text "v@" <> mypattern cons typ ns <+> text "=" $$
+  nest 4 (text "[mkElemC" <+> sc <+> cfn ns <> text "]")
+
+----
+--  text "fromContents (CElem (Elem constr [] cs):etc)" $$
+----
+readsfn n ns cn =
+  let cons   = text (constructor cn)
+      typ    = types cn
+      num    = length ns - 1
+      str d  = text "\"" <> d <> text "\""
+      trails = take num (map text [ ['c','s',y,z] | y <- ['0'..'9']
+                                                  , z <- ['0'..'9'] ])
+      cfn x  = parens (text "fromContents" <+> x)
+      (init,[last]) = splitAt num ns
+      something = parens (
+                    text "\\" <> parenList [last, text "_"] <> text "->" <+>
+                    parens (cons <+> hsep ns <> text "," <+> text "etc") )
+      mkLambda (n,cv) z = parens (
+                            text "\\" <> parenList [n,cv] <> text "->" <+>
+                            fsep [z, cfn cv] )
+  in
+  nest 4 (
+    text "|" <+> str cons <+> text "`isPrefixOf` constr =" $$
+    nest 4 (
+      if null ns then parenList [cons, text "etc"]
+      else fsep [ foldr mkLambda something (zip init trails)
+                , cfn (text "cs")]
+    )
+  )
+  -- Constructors are matched with "isPrefixOf" rather than "=="
+  -- because of parametric polymorphism.  For a datatype
+  --        data A x = A | B x
+  -- the XML tags will be <A>, <B-Int>, <B-Bool>, <B-Maybe-Char> etc.
+  -- However prefix-matching presents a problem for types like
+  --        data C = C | CD
+  -- because (C `isPrefixOf`) matches both constructors.  The solution
+  -- (implemented by "preorder") is to order the constructors such that
+  -- <CD> is matched before <C>.
+
+preorder cs =
+    map snd . reverse . sortBy (\(a,_) (b,_)-> compare a b) . zip (map constructor cs)
+
+
+--
+
+instanceheader cls dat =
+  let fv     = vars dat
+      tycon  = name dat
+      ctx    = map (\v-> text cls <+> text v)
+      parenSpace = parens . hcat . sepWith space
+  in
+  hsep [ text "instance"
+       , opt fv (\v -> parenList (ctx v) <+> text "=>")
+       , text cls
+       , opt1 (texts (tycon: fv)) parenSpace id
+       , text "where"
+       ]
+
+mypattern :: Constructor -> [a] -> [Doc] -> Doc
+mypattern c l ns =
+  if null l then text c
+  else parens (hsep (text c : take (length l) ns))
addfile ./DerivingDrift/UserRules.hs
hunk ./DerivingDrift/UserRules.hs 1
+-- stub module to add your own rules.
+module UserRules(userRules) where
+
+import DerivingDrift.RuleUtils(RuleDef) -- gives some examples 
+
+import UserRuleBinary
+import UserRuleXml
+import UserRulesGeneric
+import UserRuleGhcBinary
+import qualified DerivingDrift.RuleUtility 
+import qualified RuleFunctorM
+import qualified RuleMonoid
+
+
+-- add your rules to this list
+userRules :: [RuleDef]
+userRules = userRulesXml ++ userRulesBinary ++ userRulesGeneric ++ userRulesGhcBinary  ++ RuleUtility.rules ++ RuleFunctorM.rules ++ RuleMonoid.rules
+
addfile ./DerivingDrift/UserRulesGeneric.hs
hunk ./DerivingDrift/UserRulesGeneric.hs 1
+
+module UserRulesGeneric(userRulesGeneric) where
+
+-- import StandardRules
+import DerivingDrift.RuleUtils
+import List(intersperse)
+
+
+userRulesGeneric :: [RuleDef]
+userRulesGeneric =  [
+    ("ATermConvertible", atermfn, "Representation", "encode terms in the ATerm format", Nothing),
+    ("Typeable", typeablefn, "General", "derive Typeable for Dynamic", Nothing),
+    ("Term", dyntermfn, "Generics","Strafunski representation via Dynamic", Nothing),
+    ("HFoldable", hfoldfn, "Generics", "Strafunski hfoldr", Nothing),
+    ("Observable", observablefn, "Debugging", "HOOD observable", Nothing)
+    ]
+
+
+
+-- useful helper things
+
+addPrime doc = doc <> (text "'")
+
+ppCons cv c = mkpattern (constructor c) (types c) cv
+
+namesupply   = [text [x,y] | x <- ['a' .. 'z'], 
+                             y <- ['a' .. 'z'] ++ ['A' .. 'Z']]
+mknss []     _  = []
+mknss (c:cs) ns =
+  let (thisns,rest) = splitAt (length (types c)) ns
+  in thisns: mknss cs rest 
+
+mkpattern :: Constructor -> [a] -> [Doc] -> Doc
+mkpattern c l ns =
+  if null l then text c
+  else parens (hsep (text c : take (length l) ns))
+
+instanceheader cls dat =
+  let fv     = vars dat
+      tycon  = name dat
+      ctx    = map (\v-> text cls <+> text v)
+      parenSpace = parens . hcat . sepWith space
+  in
+  hsep [ text "instance"
+       , opt fv (\v -> parenList (ctx v) <+> text "=>")
+       , text cls
+       , opt1 (texts (tycon: fv)) parenSpace id
+       , text "where"
+       ]
+
+doublequote str
+  = "\""++str++"\""
+
+mkList :: [Doc] -> Doc
+mkList xs = text "[" <> hcat (punctuate comma xs) <> text "]"
+
+typeablefn :: Data -> Doc
+typeablefn  dat  
+  = tcname <+> equals <+> text "mkTyCon" <+> text (doublequote $ name dat) $$
+    instanceheader "Typeable" dat $$ block (
+	[ text "typeOf x = mkAppTy"  <+> 
+	  tcname <+> 
+	  text "[" <+> hcat (sepWith comma (map getV' (vars dat))) <+> text "]" $$ 
+	  wheres ]) 
+    where
+      tcname = text ("_tc_" ++ (name dat)  ++ "Tc")
+      wheres = where_decls (map getV (vars dat))
+      tpe    = text (name dat) <+> hcat (sepWith space (map text (vars dat)))
+      getV' var
+        = text "typeOf" <+> parens (text "get" <> text var <+> text "x")
+      getV var 
+        = text "get" <> text var <+> text "::" <+> tpe <+> text "->" <+> text var $$
+          text "get" <> text var <+> equals <+> text "undefined"
+
+where_decls [] = empty 
+where_decls ds = text "  where" $$ block ds
+
+dyntermfn :: Data -> Doc
+dyntermfn dat = instanceheader "Term" dat $$ block [ 
+    text "explode (x::"<>a<>text ") = TermRep (toDyn x, f x, g x) where", block (
+	zipWith f cvs cs ++ zipWith g cvs cs
+	)] where
+	    f cv c = text "f" <+> ppCons cv c <+> equals <+> mkList (map (text "explode" <+>) $ vrs c cv)
+	    g cv c = text "g" <+> ppCons underscores c <+> text "xs" <+> 
+--		text "|" <+> mkList (vrs c cv) <+> text "<- TermRep.fArgs xs" <+> equals <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::a" ) 
+		equals <+> text "case TermRep.fArgs xs of" <+> mkList (vrs c cv) <+> text "->" <+> text "toDyn" <+> parens (parens (text (constructor c) <+> hsep (map h (vrs c cv))) <> text "::"<>a<>text "" ) <> text " ; _ -> error \"Term explosion error.\""
+	    h n = parens $ text "TermRep.fDyn" <+> n
+	    cvs = mknss cs namesupply
+	    cs = body dat
+	    vrs c cv = take (length (types c)) cv
+	    underscores = repeat $ text "_"
+	    a = text (name dat) <+> hcat (sepWith space (map text (vars dat)))
+    
+
+-- begin observable 
+
+observablefn :: Data -> Doc
+observablefn  dat = 
+  let cs  = body dat
+      cvs = mknss cs namesupply
+  in
+  instanceheader "Observable" dat $$ 
+  block (zipWith observefn cvs cs)
+
+observefn cv c = 
+    text "observer" <+> ppCons cv c <+> text "= send"  <+> text (doublequote (constructor c)) <+> parens (text "return" <+> text (constructor c) <+> hsep (map f (take (length (types c)) cv))) where
+    f n = text "<<" <+> n
+
+
+
+
+
+
+-- begin of ATermConvertible derivation 
+-- Author: Joost.Visser@cwi.nl
+
+atermfn dat
+  = instanceSkeleton "ATermConvertible" 
+      [ (makeToATerm (name dat),defaultToATerm)
+      , (makeFromATerm (name dat),defaultFromATerm (name dat))
+      ] 
+      dat
+
+makeToATerm name body
+  = let cvs = head (mknss [body] namesupply)
+    in text "toATerm" <+> 
+       ppCons cvs body <+>
+       text "=" <+>
+       text "(AAppl" <+>
+       text (doublequote (constructor body)) <+>
+       text "[" <+> 
+       hcat (intersperse (text ",") (map childToATerm cvs)) <+> 
+       text "])"
+defaultToATerm
+  = empty
+childToATerm v
+  = text "toATerm" <+> v
+
+makeFromATerm name body
+  = let cvs = head (mknss [body] namesupply)
+    in text "fromATerm" <+> 
+       text "(AAppl" <+>
+       text (doublequote (constructor body)) <+>
+       text "[" <+> 
+       hcat (intersperse (text ",") cvs) <+> 
+       text "])" <+>
+       text "=" <+> text "let" <+>
+       vcat (map childFromATerm cvs) <+>
+       text "in" <+>
+       ppCons (map addPrime cvs) body
+defaultFromATerm name
+  = hsep $ texts ["fromATerm", "u", "=", "fromATermError", (doublequote name), "u"]
+childFromATerm v
+  = (addPrime v) <+> text "=" <+> text "fromATerm" <+> v
+
+-- end of ATermConvertible derivation
+
+-- begin of HFoldable derivation 
+-- Author: Joost Visser and Ralf Laemmel
+
+hfoldfn dat
+  = instanceSkeleton "HFoldable" 
+      [ (make_hfoldr (name dat), default_hfoldr),
+        (make_conof (name dat), default_conof)
+      ] 
+      dat
+
+make_hfoldr name body
+  = let cvs = head (mknss [body] namesupply)
+    in text "hfoldr'" <+> 
+       text "alg" <+>
+       ppCons cvs body <+>
+       text "=" <+>
+       foldl (\rest var -> text "hcons alg" <+> var  <+> parens rest) 
+             (text "hnil alg" <+> text (constructor body))
+             cvs 
+
+default_hfoldr
+  = empty
+  
+make_conof name body
+  = let cvs = head (mknss [body] namesupply)
+    in text "conOf" <+> 
+       ppCons cvs body <+>
+       text "=" <+>
+       text (doublequote (constructor body))
+
+default_conof
+  = empty
+
+
addfile ./E/Barendregt.hs
hunk ./E/Barendregt.hs 1
+module E.Barendregt where
+
+don't use
+
+import E.E
+import Control.Monad.State
+import qualified IntMap as IM
+import qualified IntSet as IS
+import FreeVars
+
+barendregt :: E -> E
+barendregt = fst . barendregt'
+
+-- ensure all bound variables have unique names.
+barendregt' :: E -> (E,IS.IntSet)
+barendregt' e = runState (s IM.empty e) (freeVars e) where
+    s :: IM.IntMap Int -> E -> State IS.IntSet E
+    s im (EVar (TVr (Just i) t)) = case IM.lookup i im of
+        Just x -> s im t >>= \t -> return $ EVar (TVr (Just x) t)
+        Nothing -> s im t >>= \t -> return $ EVar (TVr (Just i) t)
+    s im (ELam tvr e) = lp im ELam tvr e
+    s im (EPi tvr e)  = lp im EPi tvr e
+    s im (ELetRec dl e) = get >>= \ss -> let 
+        s' = s im'
+        (ss', dl', im') = foldl f (ss,[], im) dl  
+        rn (TVr j t,e) = do
+            e' <- s im' e
+            t' <- s im' t
+            return (TVr j t',e')
+        f  (ss,dl,im) (tvr@(TVr (Just i) _),e) |  i `IS.member` ss || i < 0  =  
+                (IS.insert v ss,rn (tvr { tvrIdent = Just v },e):dl,IM.insert i v im) where
+            v = nv ss
+        f  (ss,dl,im) z@((TVr (Just i) _),_) = (IS.insert i ss,rn z:dl,im) 
+        f _ _ = error "invalid ELetRec"
+        in do
+            put ss'
+            dl'' <- sequence dl' 
+            e' <- s' e
+            return $ ELetRec (reverse dl'') e'
+    s im (EAp a b) = liftM2 EAp (s im a) (s im b)
+    s im (ELit l) = fmap ELit $ sLit im l
+    s im (EError x e) = s im e >>= \e -> return (EError x e)
+    s im (EPrim x es e) = mapM (s im) es >>= \es -> s im e >>= \e -> return (EPrim x es e)
+    s im (ECase e alt) = s im e >>= \e -> sequence [ sPat im p >>= \p -> s im e >>= \e -> return (p,e) | (p,e) <- alt] >>= \as -> return (ECase e as) 
+    s _ e = return e
+    sLit im (LitCons x es e) = mapM (s im) es >>= \es -> s im e >>= \e -> return (LitCons x es e)
+    sLit _ l = return l
+    sPat im (PatLit l) = fmap PatLit $ sLit im l
+    sPat _ p = return p
+    nv ss = v (2 * (IS.size ss + 1)) where 
+        v n | n `IS.member` ss = v (n + 2)
+        v n = n
+    lp im lam (TVr (Just i) t) e  = do 
+        ss <- get
+        let (v,im') = (if i `IS.member` ss || i < 0 then 
+                (nv ss,(IM.insert i v im)) else (i,im))
+        modify (IS.insert v)
+        t' <- s im' t 
+        let ntvr =  (TVr (Just v) t')
+        fmap  (lam ntvr) (s im' e)
+    lp im lam (TVr Nothing t) e = do
+        t' <- s im t
+        e' <- s im e
+        return $ lam (TVr Nothing t') e'
+
+{-
+-- ensure all bound variables have unique names.
+barendregt :: E -> E
+barendregt e = evalState (s IM.empty e) (freeVSet e) where
+    s :: IM.IntMap E -> E -> State IS.IntSet E
+    s im (EVar (TVr (Just i) t)) = case IM.lookup i im of
+        Just x -> return x
+        Nothing -> s im t >>= \t -> return $ EVar (TVr (Just i) t)
+    s im (ELam tvr e) = lp im ELam tvr e
+    s im (EPi tvr e)  = lp im EPi tvr e
+    s im (ELetRec dl e) = get >>= \ss -> let 
+        s' = s im'
+        (ss', dl', im') = foldl f (ss,[], im) dl  
+        f  (ss,dl,im) ((TVr (Just i) t),e) |  i `IS.member` ss  =  
+                (IS.insert v ss,(s' e >>= \e' -> return (ntvr,e')):dl,IM.insert i (EVar ntvr) im) where
+            v = nv ss
+            ntvr =  TVr (Just v) t  -- TODO fix
+        f  (ss,dl,im) ((TVr (Just i) t),e) = 
+                (IS.insert i ss,(s' e >>= \e' -> return (ntvr, e')):dl,IM.insert i (EVar ntvr) im) where
+            ntvr = TVr (Just i) t  -- TODO fix
+        f _ _ = error "invalid ELetRec"
+        in do
+            put ss'
+            dl'' <- sequence dl' 
+            e' <- s' e
+            return $ ELetRec dl'' e'
+    s im (EAp a b) = liftM2 EAp (s im a) (s im b)
+    --s im ss (ELit (LitCons x es e)) = ELit (LitCons x (map (s im ss) es) (s im ss e))
+    s im (ELit l) = fmap ELit $ sLit im l
+    s im (EError x e) = s im e >>= \e -> return (EError x e)
+    s im (EPrim x es e) = mapM (s im) es >>= \es -> s im e >>= \e -> return (EPrim x es e)
+    s im (ECase e alt) = s im e >>= \e -> sequence [ sPat im p >>= \p -> s im e >>= \e -> return (p,e) | (p,e) <- alt] >>= \as -> return (ECase e as) 
+    s _ e = return e
+    sLit im (LitCons x es e) = mapM (s im) es >>= \es -> s im e >>= \e -> return (LitCons x es e)
+    sLit _ l = return l
+    sPat im (PatLit l) = fmap PatLit $ sLit im l
+    sPat _ p = return p
+    nv ss = v (2 * IS.size ss) where 
+        v n | n `IS.member` ss = v (n + 2)
+        v n = n
+    lp im lam (TVr (Just i) t) e  = do 
+        t' <- s im t 
+        ss <- get
+        case i `IS.member` ss of 
+            True -> do
+                let v = nv (ss `IS.union` freeVSet t')        
+                let ntvr =  (TVr (Just v) t')
+                modify (IS.insert v)
+                fmap  (lam ntvr) (s (IM.insert i (EVar ntvr) im)  e)
+            False -> do
+                let ntvr =  (TVr (Just i) t')
+                modify (IS.insert i)
+                fmap  (lam ntvr) (s (IM.insert i (EVar ntvr) im)  e)
+    lp im lam (TVr Nothing t) e = do
+        t' <- s im t
+        e' <- s im e
+        return $ lam (TVr Nothing t') e'
+        -}
addfile ./E/CPR.hs
hunk ./E/CPR.hs 1
+module E.CPR(Val(..), cprAnalyzeBinds, cprAnalyze) where
+
+import E.E
+import qualified Data.Map as Map
+import qualified Doc.Chars as C
+import Data.Monoid()
+import Name
+import Data.Generics
+import Doc.DocLike
+import Control.Monad.Writer
+import E.Values
+import qualified Info
+
+newtype Env = Env (Map.Map TVr Val)
+    deriving(Monoid)
+
+data Val =
+    Top           -- the top.
+    | Fun Val     -- function taking an arg
+    | Tup Name    -- A constructed product
+    | Tag [Name]  -- A nullary constructor, like True, False
+    | Bot         -- the bottom
+    deriving(Eq,Ord,Typeable)
+
+instance Show Val where
+    showsPrec _ Top = C.top
+    showsPrec _ Bot = C.bot
+    showsPrec n (Fun v) = C.lambda <> showsPrec n v
+    showsPrec _ (Tup n) = shows n
+    -- showsPrec _ (Tag [n]) = shows n
+    showsPrec _ (Tag ns) = shows ns
+
+lub :: Val -> Val -> Val
+lub Bot a = a
+lub a Bot = a
+lub Top a = Top
+lub a Top = Top
+lub (Tup a) (Tup b)
+    | a == b = Tup a
+    | otherwise = Top
+lub (Fun l) (Fun r) = Fun (lub l r)
+lub (Tag xs) (Tag ys) = Tag (smerge xs ys)
+lub (Tag _) (Tup _) = Top
+lub (Tup _) (Tag _) = Top
+lub a b = error $ "CPR.lub: " ++ show (a,b)
+
+
+instance Monoid Val where
+    mempty = Bot
+    mappend = lub
+
+
+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
+
+cprAnalyzeBinds :: Env -> [(TVr,E)] -> ([(TVr,E)],Env)
+cprAnalyzeBinds env bs = f env  (decomposeDefns bs) [] where
+    f env (Left (t,e):rs) zs = case cprAnalyze 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 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 :: Env -> E -> (E,Val)
+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 ds e) = (ELetRec ds' e',val) where
+    (ds',env') = cprAnalyzeBinds env ds   
+    (e',val) = cprAnalyze (env' `mappend` env) e
+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 {})) = Top
+    f (ELit (LitCons n [] _)) = Tag [n]
+    f (ELit (LitCons n _  _)) = Tup n
+    f (EPi _ _) = Tup tArrow
+    f (EPrim {}) = Top -- TODO fix primitives
+    f (EError {}) = Bot
+    f e = error $ "cprAnalyze.f: " ++ show e 
+    {-
+    f (ELam t e) = Fun (cprAnalyze (Env $ Map.insert t Top mp)  e)
+    f (EVar v)
+        | Just v <- Map.lookup v mp = v
+        | otherwise = Top
+     -}
+
+
+
+
addfile ./E/Diff.hs
hunk ./E/Diff.hs 1
+
+-- | Attempt to find pretty printable differences between terms.
+
+
+module E.Diff where
+
+import E.E
+import E.Inline
+import 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
+    
+
+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
+    
+    
+
+
addfile ./E/E.hs
hunk ./E/E.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+module E.E(module E.E, subst) where
+
+import GenUtil
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import qualified Data.Set as Set
+import Control.Monad.Identity
+import Monad
+import Data.Generics
+import Data.FunctorM
+import Maybe
+import List
+import DDataUtil()
+import Doc.DocLike
+import VConsts
+import Name
+import Data.Graph as G
+import FreeVars
+import Binary
+import Atom
+import CanType
+import {-# SOURCE #-} E.Subst 
+import C.Prims
+import Data.Monoid
+import Number
+import qualified Info
+
+
+
+--------------------------------------
+-- Lambda Cube (it's just fun to say.)
+--------------------------------------
+
+
+data Lit e t = LitInt Number t |  LitCons Name [e] t --  | LitFrac Rational t   LitInt !Integer t  |
+	deriving(Data,Eq,Ord, Typeable) 
+        {-!derive: is, GhcBinary !-}
+
+
+
+instance (Show e,Show t) => Show (Lit e t) where
+    --show (LitInt x _) = show x
+    --show (LitFrac r _) = show r
+    show (LitInt x _) = show x
+    show (LitCons n es t) = parens $  hsep (show n:map show es) <> "::" <> show t  
+
+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 a es e) -> do es <- mapM f es; e <- f e; return (LitCons a es e)
+        (LitCons a es e) -> do  e <- f e; return (LitCons a es e)
+        LitInt i t -> do t <- f t; return $ LitInt i t
+        --LitFrac r t -> do t <- f t; return $ LitFrac r t
+
+
+
+data ESort = 
+    EStar     -- ^ the sort of types
+    | EHash   -- ^ the sort of unboxed types
+    | EBox    -- ^ the sort of types of types
+
+data E = EAp E E 
+    | ELam TVr E 
+    | EPi TVr E 
+    | EVar TVr 
+    | Unknown 
+    | ESort !Int 
+    | ELit !(Lit E E) 
+    | ELetRec [(TVr, E)] E 
+    | EPrim APrim [E] E 
+    | EError String E 
+    | ECase {    
+       eCaseScrutinee :: E, 
+       eCaseBind :: TVr,
+       eCaseAlts :: [Alt E],
+       eCaseDefault :: (Maybe E)
+       }
+	deriving(Data,Eq, Typeable, Show)
+    {-! derive: is, from, GhcBinary !-}
+
+
+data EBind = EBind [TVr] E
+    deriving(Data,Eq,Typeable,Show)
+    {-! derive: GhcBinary !-}
+
+
+fromAp e = f [] e where
+    f as (EAp e a) = f (a:as) e
+    f as e  =  (e,as)
+--fromAp _ = fail "not application" 
+
+--fromPi (EPi (EBind ts e)) = (e,ts)
+--fromLam (ELam (EBind ts e)) = (e,ts)
+
+fromPi e = f [] e where
+    f as (EPi v e) = f (v:as) e
+    f as e  =  (e,reverse as)
+
+-- (b,ls) = fromLam (foldr ELam b ls)
+fromLam e = f [] e where
+    f as (ELam v e) = f (v:as) e
+    f as e  =  (e,reverse as)
+
+type TVr = TVr' E
+data TVr' e = TVr { tvrIdent :: !Int, tvrType :: e, tvrInfo :: Info.Info }
+    deriving(Data,Typeable)
+    {-! derive: update !-}
+
+tVr x y = tvr { tvrIdent = x, tvrType = y } 
+
+tvr = TVr { tvrIdent = 0, tvrType = Unknown, tvrInfo = mempty } 
+
+data TvrBinary = TvrBinaryNone | TvrBinaryAtom Atom | TvrBinaryInt Int
+    {-! derive: GhcBinary !-}
+
+instance Binary TVr where
+    put_ bh (TVr 0 e _) = do
+        put_ bh (TvrBinaryNone)
+        put_ bh e
+    put_ bh (TVr (i) e _) | Just x <- intToAtom i = do
+        put_ bh (TvrBinaryAtom x)
+        put_ bh e
+    put_ bh (TVr (i) e _) = do
+        put_ bh (TvrBinaryInt i)
+        put_ bh e
+    get bh = do
+        (x ) <- get bh 
+        e <- get bh 
+        case x of
+            TvrBinaryNone -> return $ TVr 0 e mempty 
+            TvrBinaryAtom a -> return $ TVr (atomIndex a) e mempty 
+            TvrBinaryInt i -> return $ TVr (i) e mempty 
+
+instance Show a => Show (TVr' a) where
+    show TVr { tvrIdent = 0, tvrType = e} = "(_::" ++ show e ++ ")"
+    show TVr { tvrIdent = (x), tvrType =  e} | Just n <- intToAtom x  = "(v" ++ show (fromAtom n::Name) ++ "::" ++ show e ++ ")"
+    show TVr { tvrIdent = (x), tvrType = e}  = "(v" ++ show x ++ "::" ++ show e ++ ")"
+
+tvrNum TVr { tvrIdent =  n } = n
+--tvrNum _ = 0
+
+
+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) 
+
+--instance FunctorM Pat where
+--    fmapM f (PatLit l) = fmapM f l >>= return . PatLit 
+--    fmapM _ PatWildCard = return PatWildCard
+
+
+
+
+
+--type Alt e = (Lit TVr e,e)
+data Alt e = Alt (Lit TVr e) e
+    deriving(Data,Show,Eq,Typeable)
+       {-!derive: GhcBinary !-}
+
+altHead :: Alt E -> Lit () ()
+altHead (Alt l _) = litHead  l
+litHead :: Lit a b -> Lit () ()
+--litHead (LitFrac x _) = LitFrac x ()
+litHead (LitInt x _) = LitInt x ()
+litHead (LitCons s _ _) = LitCons s [] ()
+
+litBinds ((LitCons _ xs _) ) = xs 
+litBinds _ = []
+
+patToLitEE (LitCons n [a,b] t) | t == eStar, n == tArrow = EPi (tVr 0 (EVar a)) (EVar b)
+patToLitEE (LitCons n xs t) = ELit $ LitCons n (map EVar xs) t
+patToLitEE (LitInt x t) = ELit $ LitInt x t
+--patToLitEE (LitFrac x t) = LitFrac x t
+
+tArrow = toName TypeConstructor ("Prelude","->")
+
+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 _ xs _ <- casePats ec]
+
+--data Pat e = PatLit !(Lit e) | PatWildCard 
+--	deriving(Data,Show, Eq, Typeable)
+--    {-!derive: is, GhcBinary !-}
+
+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
+--    (<) (TVr x _) (TVr y _) = (<) x y
+--    (<=) (TVr x _) (TVr y _) = (<=) x y
+--    (>=) (TVr x _) (TVr y _) = (>=) x y
+--    (>) (TVr x _) (TVr y _) = (>) x y
+
+
+isWHNF ELit {} = True
+isWHNF ELam {} = True
+isWHNF EPi {} = True
+isWHNF ESort {} = True
+isWHNF (ELetRec _ e) = isWHNF e
+isWHNF _ = False
+
+
+-----------
+-- E values
+-----------
+
+instance TypeNames E where
+    tStar = ESort 0
+    tInt = ELit (LitCons tInt [] eStar)
+    tRational = ELit (LitCons (toName TypeConstructor ("Ratio","Ratio")) [tInteger] eStar)
+    tChar = ELit (LitCons tChar [] eStar)
+    tBool = ELit (LitCons tBool [] eStar)
+    tUnit = ELit (LitCons tUnit [] eStar)
+    tString =  (ELit (litCons TypeConstructor ("Prelude","[]") [tChar] eStar))   
+    tInteger = ELit (LitCons tInteger [] eStar)
+    tWorld__ = ELit (LitCons tWorld__ [] eStar)
+    tIntzh = ELit (LitCons tIntzh [] eStar)
+    tIntegerzh = ELit (LitCons tIntegerzh [] eStar)
+    tCharzh = ELit (LitCons tCharzh [] eStar)
+
+instance ConNames E where 
+    vTrue = ELit vTrue
+    vFalse = ELit vFalse
+    vUnit  = ELit vUnit
+
+instance ConNames (Lit x E) where
+    vTrue  = (LitCons vTrue [] tBool)
+    vFalse = (LitCons vFalse [] tBool)
+    vUnit  = (LitCons vUnit [] tUnit)
+    
+    
+vWorld__ = ELit (litCons DataConstructor ("Jhc.IO","World__") [] tWorld__)
+
+-- types
+etIO t = ELit (litCons TypeConstructor ("Prelude.IO","IO") [t] tStar)
+--etWorld = ELit (litCons TypeConstructor ("Jhc.IO","World__") [] tStar)
+--tRational = ELit (litCons TypeConstructor ("Prelude.Ratio","Rational") [] tStar)
+tAbsurd k = ELit (litCons TypeConstructor "Absurd#" [] k)
+
+tFunc a b = ePi (tVr 0 a) b
+
+-- values
+
+
+
+tvrSilly = tVr ((-1)) Unknown
+
+-----------------
+-- E constructors 
+-----------------
+
+litCons t x y z = LitCons (toName t x) y z
+
+
+
+eBox = ESort 1
+eStar = ESort 0
+
+
+sortLetDecls ds = sortBy f ds where 
+    f (TVr { tvrIdent = i },_) (TVr { tvrIdent = j } ,_) = compare i j
+
+--ePi t (EPi (EBind ts b)) = EPi $  EBind (t:ts) b
+--ePi t b = EPi $  EBind [t] b
+
+ePi a b = EPi a b 
+
+eLam v (EError s t) = EError s (ePi v t)
+eLam v t = ELam v t
+--eLam t (ELam (EBind ts b)) = ELam $  EBind (t:ts) b
+--eLam t b = ELam $  EBind [t] b
+
+
+
+{-
+discardArgs 0 e = e
+discardArgs n (EPi (EBind ts b)) 
+    | n == lts = b 
+    | n < lts = EPi (EBind (drop n ts) b) 
+    where
+    lts = length ts
+discardArgs _ _ = error "discardArgs"
+-}
+
+discardArgs 0 e = e
+discardArgs n (EPi _ b) | n > 0 = discardArgs (n - 1) b
+discardArgs _ _ = error "discardArgs"
+
+
+eLetRec ds e = f (filter ((/= 0) . tvrNum . fst) ds) where
+    f [] = e
+    f ds = ELetRec ds e
+
+
+tvrName :: Monad m => TVr  -> m Name
+tvrName (TVr {tvrIdent =  n }) | Just a <- intToAtom n = return $ fromAtom a
+tvrName tvr = fail $ "TVr is not Name: " ++ show tvr
+
+tvrShowName :: TVr -> String
+tvrShowName t = maybe ('x':(show $ tvrNum t)) show (tvrName t) 
+
+
+---------------------------
+-- compatable approximation
+---------------------------
+
+eCompat :: E -> E -> Bool
+eCompat x y | x == y = True
+eCompat (EAp e1 e2) (EAp ea eb) = eCompat e1 ea && eCompat e2 eb
+eCompat (ELam (TVr { tvrType =  e1 }) e2) (ELam (TVr { tvrType =  ea }) eb) = eCompat e1 ea && eCompat e2 eb
+eCompat (EPi (TVr { tvrType = e1 }) e2) (EPi (TVr { tvrType = ea }) eb) = eCompat e1 ea && eCompat e2 eb
+eCompat (EVar _) _ = True
+eCompat _ (EVar _) = True
+eCompat (ELetRec _ e1) (ELetRec _ e2) = eCompat e1 e2
+eCompat (ELit (LitCons n es t)) (ELit (LitCons n' es' t')) = n == n' && all (uncurry eCompat) (zip es es') && eCompat t t'
+eCompat x y = x == y
+
+
+-------------------------    
+-- finding free variables
+-------------------------
+
+--freeVSet :: E -> IS.IntSet
+--freeVList :: E -> [Int]
+
+
+instance FreeVars E IS.IntSet where
+    freeVars e = IS.fromAscList (fsts . IM.toAscList $ freeVs e)
+instance FreeVars E (Set.Set Int) where
+    freeVars e = Set.fromAscList (fsts . IM.toAscList $ freeVs e)
+instance FreeVars E [Int] where 
+    freeVars e =  IM.keys $ freeVs e
+instance FreeVars E (IM.IntMap TVr) where
+    freeVars = freeVs
+instance FreeVars E (Set.Set TVr) where
+    freeVars x = Set.fromList $ freeVars x
+instance FreeVars E [TVr] where
+    freeVars x = IM.elems $ freeVars x
+instance FreeVars (Alt E) (IM.IntMap TVr) where
+    freeVars as@(Alt l e) = IM.unions $ freeVars (getType l):(freeVars e IM.\\ IM.fromList [ (tvrNum t,t) | t <- litBinds l]):( map (freeVars . getType) $ litBinds l) 
+instance FreeVars E t => FreeVars TVr t where
+    freeVars tvr = freeVars (getType tvr)
+instance FreeVars (Alt E) (Set.Set Int) where
+    freeVars as@(Alt l e) = Set.unions $ freeVars (getType l):(freeVars e Set.\\ Set.fromList [ tvrNum t | t <- litBinds l]):( map (freeVars . getType) $ litBinds l) 
+
+
+instance FreeVars E x => FreeVars (Lit TVr E) x where
+    freeVars l =  mconcat $ freeVars (getType l):(map (freeVars . getType) $ litBinds l) 
+    
+
+
+freeVs :: E -> IM.IntMap TVr
+freeVs =   fv where
+    (<>) = IM.union
+    delete = IM.delete
+    fv (EAp e1 e2) = fv e1 <> fv e2
+    fv (EVar tvr@(TVr { tvrIdent =  ( i), tvrType =  t })) = IM.insert i tvr (fv t)
+    fv (ELam (TVr { tvrIdent = ( i), tvrType =  t }) e) =  (delete i $ fv e <> fv t)
+    --fv (ELam (TVr Nothing t) e) = fv t <> fv e
+    fv (EPi (TVr { tvrIdent =  ( i), tvrType =  t}) e) =  (delete i $ fv e <> fv t)
+    --fv (EPi (TVr Nothing t) e) = fv t <> fv e
+    fv (ELetRec dl e) =  ((tl <> bl <> fv e) IM.\\ IM.fromList ll)  where
+        (ll,tl,bl) = liftT3 (id,IM.unions,IM.unions) $ unzip3 $ 
+            map (\(tvr@(TVr { tvrIdent = j, tvrType =  t}),y) -> ((j,tvr), fv t, fv y)) dl
+
+    --fv (ECase e alts ) = IM.unions ( foldl (flip ($)) [fv e] [ \x -> fvPat p:fv e:x | (p,e) <- alts] )
+    fv (EError _ e) = fv e
+    fv (ELit l) = fvLit l
+    fv (EPrim _ es e) = IM.unions $ fv e : map fv es
+    fv (ECase e b as d) = IM.unions ( fv e:freeVars (getType $ b):(IM.delete (tvrNum b) $ IM.unions (freeVars d:map freeVars as)  ):[])
+    fv Unknown = IM.empty
+    fv ESort {} = IM.empty
+    fvLit (LitCons _ es e) = IM.unions $ fv e:map fv es 
+    fvLit l = freeVs (getType l)
+    --fvPat (PatLit l) = fvLit l
+    --fvPat _ = IM.empty
+
+
+
+{-
+decomposeDefns :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
+decomposeDefns bs = map g (scc (map f bs)) where
+    mp = IM.fromList [ (i,e) | e@(TVr (Just i) _,_) <- bs]
+    ml i = IM.find i mp
+    f (TVr (Just i) _, e) = (i,freeVList e `union` IM.keys mp)
+    g [x] = case ( ml x) of
+        t@(_,e) | x `elem` freeVList e -> Right [t]
+                | otherwise -> Left t
+    g xs = Right (map ml xs)            
+-}
+
+decomposeDefns :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
+decomposeDefns bs = map f mp where
+    mp = G.stronglyConnComp [ (v,i,freeVars t `mappend` freeVars e) | v@(TVr i t _ ,e) <- bs]
+    f (AcyclicSCC v) = Left v 
+    f (CyclicSCC vs) = Right vs
+
+decomposeLet :: E ->  ([Either (TVr, E) [(TVr,E)]],E)
+decomposeLet (ELetRec ds e) = (decomposeDefns ds,e)
+decomposeLet e = ([],e)
+
+{-
+decomposeDefns' :: [(TVr, E)] -> [Either ((TVr, E),[Int]) [((TVr,E),[Int])]]
+decomposeDefns' bs = map f mp where
+    mp = G.stronglyConnComp [ (v,i,freeVars t `mappend` freeVars e) | v@(TVr (i) t,e) <- bs]
+    f (AcyclicSCC v) = Left v 
+    f (CyclicSCC vs) = Right vs
+-}
+
+sortStarLike e = e /= eBox && typ e == eBox
+sortTypeLike e = e /= eBox && not (sortStarLike e) && sortStarLike (typ e) 
+sortTermLike e = e /= eBox && not (sortStarLike e) && not (sortTypeLike e) && sortTypeLike (typ e) 
+
+-- Fast (and lazy, and perhaps unsafe) typeof
+typ ::  E -> E
+typ (ESort 0) =  eBox
+typ (ESort 1) = error "Box inhabits nowhere." 
+typ (ESort _) = error "What sort of sort is this?"
+typ (ELit l) = getType l
+typ (EVar v) =  getType v
+typ (EPi _ b) = typ b
+typ (EAp a b) = eAp (typ a) b
+typ (ELam (TVr { tvrIdent = x, tvrType =  a}) b) = EPi (tVr x a) (typ b)
+typ (ELetRec _ e) = typ e
+typ (ECase {eCaseScrutinee = e, eCaseDefault = Just d}) | sortTypeLike e = typ d
+typ (ECase {eCaseAlts = (x:_)}) = getType x
+typ (ECase {eCaseDefault = Just e}) = typ e
+--typ (ECase _ ((PatLit (LitCons _ es _),e):_) ) = discardArgs (length es) $ typ e
+--typ (ECase _ ((PatLit _,e):_) ) = typ e
+--typ (ECase e' ((PatWildCard,e):_) ) = typ (eAp e e')
+typ (ECase _ _ [] Nothing) = error "empty case"
+typ (EError _ e) = e
+typ (EPrim _ _ t) = t
+typ Unknown = Unknown
+--typ x = error $ "unknown expr: " ++ show x
+
+instance CanType E E where
+    getType = typ
+instance CanType TVr E where
+    getType = tvrType
+instance CanType (Lit x t) t where
+    getType (LitInt _ t) = t
+--    getType (LitFrac _ t) = t
+    getType (LitCons _ _ t) = t
+instance CanType e t => CanType (Alt e) t where
+    getType (Alt _ e) = getType e
+    
+
+eAp (EPi (TVr { tvrIdent =  0 }) b) _ = b
+eAp (EPi t b) e = subst t e b
+--eAp (EPrim n es t@(EPi _ _)) b = EPrim n (es ++ [b]) (eAp t b)  -- only apply if type is pi-like
+eAp (ELit (LitCons n es t)) b = (ELit (LitCons n (es ++ [b]) (eAp t b)))
+eAp (EError s t) b = EError s (eAp t b)
+eAp a b = EAp a b
addfile ./E/E.hs-boot
hunk ./E/E.hs-boot 1
+module E.E where
+
+type TVr = TVr' E
+data TVr' a
+data E 
addfile ./E/Eval.hs
hunk ./E/Eval.hs 1
+module E.Eval(eval, unify,strong) where
+
+-- Simple lambda Calculus interpreter
+-- does not handle recursive Let or Case statements, but those don't appear in types anyway.
+
+import E.E
+import E.Subst
+import E.Pretty
+import Seq
+import Control.Monad.Writer
+import qualified Data.Map as Map
+import Doc.PPrint
+
+
+
+eval :: E -> E
+eval term = eval' term []  where
+    eval' t@EVar {} [] = t
+    eval' (ELam v body) [] = check_eta $ ELam v (eval body)
+    eval' (EPi v body) [] = check_eta $ EPi v (eval body)
+    eval' e@Unknown [] = e
+    eval' e@ESort {} [] = e
+
+    eval' (ELit (LitCons n es t)) [] = ELit $ LitCons n (map eval es) t
+    eval' e@ELit {} [] = e
+    eval' (ELit (LitCons n es ty)) (t:rest) = eval' (ELit $ LitCons n (es ++ [t]) (eval $ EAp ty 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 ds e) stack = eval' (f (decomposeDefns 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 _ = 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
+
+
+
+-- TODO, this should take a set of free variables and α-convert lambdas
+
+unify :: Monad m => E -> E -> m [(E,E)]
+unify e1 e2 = liftM Seq.toList $ execWriterT (un e1 e2 () (0::Int)) where
+    un (EAp a b) (EAp a' b') mm c = do 
+        un a a' mm c
+        un b b' mm c
+    un a@(EVar (TVr { tvrIdent = (i), tvrType =  t}))  b@(EVar (TVr { tvrIdent = ( j), tvrType =  u})) mm c = do
+        un t u mm c 
+        when (i /= j) $ tell (Seq.single (a,b))
+    --un (ELam (TVr Nothing ta) ea) (ELam (TVr Nothing tb) eb) mm c = un ta tb mm c >> un ea eb mm c
+    --un (EPi (TVr Nothing ta) ea) (EPi (TVr Nothing tb) eb) mm c = un ta tb mm c >> un ea eb 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 (LitChar x))  (ELit (LitChar y)) mm c | x == y = return ()
+--    un (ELit (LitFrac x t1 ))  (ELit (LitFrac y t2)) mm c | x == y = un t1 t2 mm c
+    un (ELit (LitCons n xs t))  (ELit (LitCons n' ys 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 a@EVar {} b _ _ = tell (Seq.single (a,b))
+    --un a b@EVar {} _ _ = tell (Seq.single (a,b))
+    un a b _ _ = fail $ "Expressions do not unify: " ++ show a ++ show b
+    lam va ea vb eb mm c = do
+        un ea eb mm c
+    
+    -- error "cannot handle lambdas yet"
+
+        
+
+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 (ELetRec ds' e) = (Map.fromList ds'
+    eval' ds (ELit (LitCons n es t)) [] = do  
+        es' <- mapM (\e -> eval' ds e []) es 
+        t' <-  (eval' ds t [])
+        return $ ELit $ LitCons n es' t' 
+    eval' ds e@ELit {} [] = return e
+    eval' ds (ELit (LitCons n es ty)) (t:rest) = do
+        t' <- (eval' ds (EAp ty t) [])
+        eval' ds (ELit $ LitCons n (es ++ [t]) 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 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 ds' e) stack = eval' (Map.fromList ds'  `mappend` ds) e  stack 
+    --eval' ds (ELetRec ds' e) stack = eval' ds (f (decomposeDefns 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' ds (ECase e as) [] = do
+--        e' <- eval' ds e [] 
+--        let f (PatLit (LitCons n es t),e) = do
+--                e' <- eval' ds e []
+--                t' <- eval' ds t []
+--                es' <- mapM (\e -> eval' ds e []) es
+--                return (PatLit (LitCons n es' t'),e')
+--            f (p,e) = do
+--                e' <- eval' ds e []
+--                return (p,e')
+--        as' <- mapM f as
+--        return $ ECase e' as'
+        
+    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
+
addfile ./E/FromHs.hs
hunk ./E/FromHs.hs 1
+module E.FromHs(matchesConv,altConv,guardConv,convertDecls,getMainFunction,createMethods,createInstanceRules,theMainName,deNewtype,methodNames) where
+
+import Atom
+import Boolean.Algebra
+import Char
+import Class
+import Control.Monad.Identity
+import Control.Monad.State
+import C.Prims
+import DataConstructors
+import Data.FunctorM
+import Data.Generics
+import DDataUtil()
+import Doc.DocLike
+import Doc.PPrint
+import E.E
+import E.Rules
+import E.Subst
+import E.Traverse
+import E.TypeCheck
+import E.Values
+import FreeVars
+import GenUtil
+import HsSyn
+import Name
+import Options
+import Prelude hiding((&&),(||),not,and,or,any,all)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified FlagOpts as FO
+import qualified PPrint(render)
+import qualified Seq
+import Representation
+import Utils
+import VConsts
+import NameMonad
+
+localVars = [10,12..]
+theMainName = toName Name.Val (UnQual $ HsIdent "theMain")
+ump sl e = EError  (srcLocShow sl ++ ": Unmatched pattern") e
+srcLocShow sl = concat [srcLocFileName sl, ":",show $ srcLocLine sl,":", show $ srcLocColumn sl ]
+nameToInt n = atomIndex $ toAtom n
+
+
+--newVars :: MonadState Int m => [E] -> m [TVr]
+newVars xs = f xs [] where
+    f [] xs = return $ reverse xs
+    f (x:xs) ys = do
+        s <- get
+        put $! s + 2
+        f xs (tVr ( s) x:ys)
+
+lt n =  atomIndex $ toAtom $ toName TypeVal n
+
+tipe (TAp t1 t2) = eAp (tipe t1) (tipe t2)
+tipe (TArrow t1 t2) =  EPi (tVr 0 (tipe t1)) (tipe t2)
+tipe (TCon (Tycon n k)) =  ELit (LitCons (toName TypeConstructor n) [] (kind k))
+tipe (TVar (Tyvar _ n k)) = EVar (tVr (lt n) (kind k))
+tipe (TGen _ (Tyvar _ n k)) = EVar (tVr (lt n) (kind k))
+--tipe (TTuple ts) = ltTuple (map tipe ts)
+--    tipe (TCon (Tycon n k)) = foldr ($) (ELit (LitCons (getName n) (map EVar es) rt)) (map ELam es) where
+--        (ts,rt) = argTypes' (kind k)
+--        es = [ (TVr (Just n) t) |  t <- ts | n <- localVars ]
+
+kind Star = eStar
+kind (Kfun k1 k2) = EPi (tVr 0 (kind k1)) (kind k2)
+kind (KVar _) = error "Kind variable still existing."
+
+
+
+simplifyDecl (HsPatBind sl (HsPVar n)  rhs wh) = HsFunBind [HsMatch sl n [] rhs wh]
+simplifyDecl x = x
+
+simplifyHsPat (HsPInfixApp p1 n p2) = HsPApp n [simplifyHsPat p1, simplifyHsPat p2]
+simplifyHsPat (HsPParen p) = simplifyHsPat p
+simplifyHsPat (HsPTuple ps) = HsPApp (toTuple (length ps)) (map simplifyHsPat ps)
+simplifyHsPat (HsPNeg p)
+    | HsPLit (HsInt i) <- p' = HsPLit $ HsInt (negate i)
+    | HsPLit (HsFrac i) <- p' = HsPLit $ HsFrac (negate i)
+    | otherwise = HsPNeg p'
+    where p' = (simplifyHsPat p)
+simplifyHsPat (HsPLit (HsString s)) = simplifyHsPat (HsPList (map f s)) where
+    f c = HsPLit (HsChar c)
+simplifyHsPat (HsPAsPat n p) = HsPAsPat n (simplifyHsPat p)
+simplifyHsPat (HsPTypeSig _ p _) = simplifyHsPat p
+simplifyHsPat (HsPList ps) = pl ps where
+    pl [] = HsPApp (Qual prelude_mod (HsIdent "[]")) []
+    pl (p:xs) = HsPApp (Qual prelude_mod (HsIdent ":")) [simplifyHsPat p, pl xs]
+simplifyHsPat (HsPApp n xs) = HsPApp n (map simplifyHsPat xs)
+simplifyHsPat (HsPIrrPat p) = simplifyHsPat p -- TODO irrefutable patterns!
+simplifyHsPat p@HsPVar {} = p
+simplifyHsPat p@HsPLit {} = p
+simplifyHsPat p = error $ "simplifyHsPat: " ++ show p
+
+convertVal assumps n = (mp EPi ts (tipe t), mp eLam ts) where
+    Just (Forall _ (_ :=> t)) = Map.lookup n assumps -- getAssump n
+    mp fn (((Tyvar _ n k)):rs) t = fn (tVr (lt n) (kind k)) (mp fn rs t)
+    mp _ [] t = t
+    ts = ctgen t
+    lt n =  nameToInt (fromTypishHsName  n)
+
+convertOneVal (Forall _ (_ :=> t)) = (mp EPi ts (tipe t)) where
+    mp fn (((Tyvar _ n k)):rs) t = fn (tVr (lt n) (kind k)) (mp fn rs t)
+    mp _ [] t = t
+    ts = ctgen t
+    lt n =  nameToInt (fromTypishHsName  n)
+
+Identity nameFuncNames = fmapM (return . toName Val) sFuncNames
+toTVr assumps n = tVr ( nameToInt n) (typeOfName n) where
+    typeOfName n = fst $ convertVal assumps n
+    --lt n = nameToInt (fromTypishHsName  n)
+
+matchesConv ms = map v ms where
+    v (HsMatch _ _ ps rhs wh) = (map simplifyHsPat ps,rhs,wh)
+
+altConv as = map v as where
+    v (HsAlt _ p rhs wh) = ([simplifyHsPat p],guardConv rhs,wh)
+
+guardConv (HsUnGuardedAlt e) = HsUnGuardedRhs e
+guardConv (HsGuardedAlts gs) = HsGuardedRhss (map (\(HsGuardedAlt s e1 e2) -> HsGuardedRhs s e1 e2) gs)
+
+argTypes e = span ((== eBox) . typ) (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 => Name -> (Map.Map Name (TVr,E)) -> m (Name,TVr,E)
+getMainFunction name ds = ans where
+    ans = do
+        main <- findName name
+        runMain <- findName (func_runMain nameFuncNames)
+        runExpr <- findName (func_runExpr nameFuncNames)
+        let e | not (fopts FO.Wrapper) = maine
+              | otherwise = case ioLike (typ maine) of
+                Just x ->  EAp (EAp (EVar runMain)  x ) maine
+                Nothing ->  EAp (EAp (EVar runExpr) ty) maine
+            theMain = (theMainName,theMainTvr,e)
+            theMainTvr =  tVr (nameToInt theMainName) (typ e)
+            tvm@(TVr { tvrType =  ty}) =  main
+            maine = foldl EAp (EVar tvm) [ tAbsurd k |  TVr { tvrType = k } <- xs ]
+            (ty',xs) = fromPi ty
+        return theMain
+    ioLike ty = case smplE ty of
+        ELit (LitCons n [x] _) -> if show n ==  "Jhc.IO.IO" then Just x else Nothing
+        _ -> Nothing
+    smplE = id
+
+        {-
+    lco = ELetRec [ (_,x,y) hoEs ds]
+    main = toTVr (hoAssumps ho) (parseName Val wt)
+    -}
+    --nameMap = Map.fromList [ (n,t) |  (n,t,_) <- ds]
+    findName name = case Map.lookup name ds of
+        Nothing -> fail $ "Cannot find: " ++ show name
+        Just (n,_) -> return n
+
+createInstanceRules :: Monad m => ClassHierarchy -> (Map.Map Name (TVr,E)) -> m Rules
+createInstanceRules classHierarchy funcs = return $ fromRules ans where
+    ans = concatMap cClass (classRecords classHierarchy)
+    --cClass ClassRecord { className = name, classInsts = is, classAssumps = as } =  concat [ method n | n :>: _ <- as ]
+    cClass classRecord =  concat [ method classRecord n | n :>: Forall _ (_ :=> t) <- classAssumps classRecord ]
+
+    method classRecord n = as where
+        methodVar = tVr ( nameToInt methodName) ty
+        methodName = toName Name.Val n
+        Identity (deftvr@(TVr { tvrType = ty}),_) = findName defaultName
+        defaultName =  (toName Name.Val (defaultInstanceName n))
+        valToPat' (ELit (LitCons x ts t)) = ELit $ LitCons x [ EVar (tVr ( j) (typ z)) | z <- ts | j <- [2,4 ..]]  t
+        valToPat' (EPi (TVr { tvrType =  a}) b)  = ELit $ LitCons tArrow [ EVar (tVr ( j) (typ z)) | z <- [a,b] | j <- [2,4 ..]]  eStar
+        valToPat' x = error $ "FromHs.valToPat': " ++ show x
+        as = [ rule  t | (_ :=> IsIn _ t ) <- snub (classInsts classRecord) ]
+        rule t = emptyRule { ruleHead = methodVar, ruleArgs = [valToPat' (tipe t)], ruleBody = body, ruleName = toAtom $ "Rule.{" ++ show name ++ "}"}  where
+            name = (toName Name.Val (instanceName n (getTypeCons t)))
+            ELit (LitCons _ vs _) = valToPat' (tipe t)
+            body = case findName name of Just (n,_) -> foldl EAp (EVar n) vs  ; Nothing -> EAp (EVar deftvr) (valToPat' (tipe t))
+    findName name = case Map.lookup name funcs of
+        Nothing -> fail $ "Cannot find: " ++ show name
+        Just n -> return n
+
+createMethods :: Monad m => DataTable -> ClassHierarchy -> (Map.Map Name (TVr,E))  -> m [(Name,TVr,E)]
+createMethods dataTable classHierarchy funcs = return ans where
+    ans = concatMap cClass (classRecords classHierarchy)
+    cClass classRecord =  [ method classRecord n | n :>: _ <- classAssumps classRecord ]
+    method classRecord n = (methodName ,tVr ( nameToInt methodName) ty,v) where
+        methodName = toName Name.Val n
+        Just (deftvr@(TVr { tvrType = ty}),defe) = findName (toName Name.Val (defaultInstanceName n))
+        (EPi tvr t) = ty
+        --els = eAp (EVar deftvr) (EVar tvr)
+        els = EError ("Bad: " ++ show methodName) t -- eAp (EVar deftvr) (EVar tvr)
+        v = eLam tvr (eCase (EVar tvr) as els)
+        as = concatMap cinst [ t | (_ :=> IsIn _ t ) <- classInsts classRecord]
+        cinst t | Nothing <- getConstructor x dataTable = fail "skip un-imported primitives"
+                | Just (tvr,_) <- findName name = return $ calt (foldl EAp (EVar tvr) vs)
+                | EError "Bad" _ <- defe = return $ calt $  EError ( show n ++ ": undefined at type " ++  PPrint.render (pprint  t) ) (typ els)
+                | otherwise = return $ calt $ ELetRec [(tvr,tipe t)] (EAp (EVar deftvr) (EVar tvr))
+                | ELam x e <- defe, not (isAtomic (tipe t)) = return $ calt $ eLetRec [(x,tipe t)] e
+                | ELam x e <- defe, isAtomic (tipe t) = return $ calt $ subst x (tipe t) e -- [(x,tipe t)] e
+                | not (isAtomic (tipe t)) = return $ calt $  (EAp (EVar deftvr) (EVar tvr))
+                | otherwise = return $ calt $ EAp (EVar deftvr) (tipe t) where -- fail "Instance does not exist" where
+            name = toName Name.Val (instanceName n (getTypeCons t))
+            -- calt  tvr =  Alt (LitCons x [ tvr | ~(EVar tvr) <- vs ]  ct) (foldl EAp (EVar tvr) vs)
+            calt e =  Alt (LitCons x [ tvr | ~(EVar tvr) <- vs ]  ct)  e
+            (x,vs,ct) = case tipe t of
+                (ELit (LitCons x' vs' ct')) -> (x',vs',ct')
+                (EPi (TVr { tvrType = a}) b) -> (tArrow,[a,b],eStar)
+                e -> error $ "FromHs.createMethods: " ++ show e
+    findName name = case Map.lookup name funcs of
+        Nothing -> fail $ "Cannot find: " ++ show name
+        Just n -> return n
+
+methodNames ::  ClassHierarchy ->  [TVr]
+methodNames  classHierarchy =  ans where
+    ans = concatMap cClass (classRecords classHierarchy)
+    cClass classRecord =  [ tVr (nameToInt $ toName Name.Val n) (convertOneVal t) | n :>: t <- classAssumps classRecord ]
+
+unbox :: DataTable -> E -> Int -> (TVr -> E) -> E
+unbox dataTable e vn wtd = ECase e (tVr 0 te) [Alt (LitCons cna [tvra] te) (wtd tvra)] Nothing where
+    te = typ e
+    tvra = tVr vn sta
+    Just (cna,sta,ta) = lookupCType' dataTable te
+
+createFunc :: DataTable -> [Int] -> [E] -> ([(TVr,String)] -> E) -> E
+createFunc dataTable ns es ee = foldr ELam eee tvrs where
+    xs = [(tVr n te,n',runIdentity $ lookupCType' dataTable te) | te <- es | n <- ns | n' <- drop (length es) ns ]
+    tvrs' = [ (tVr n' sta,rt) | (_,n',(_,sta,rt)) <- xs ]
+    tvrs = [ t | (t,_,_) <- xs]
+    eee = foldr esr (ee tvrs') xs
+    esr (tvr,n',(cn,st,_)) e = ECase (EVar tvr) (tVr 0 te) [Alt (LitCons cn [tVr n' st] te) e] Nothing  where
+        te = typ $ EVar tvr
+
+
+
+
+convertDecls :: Monad m => ClassHierarchy -> Map.Map Name Scheme -> DataTable -> [HsDecl] -> m [(Name,TVr,E)]
+convertDecls classHierarchy assumps dataTable hsDecls = return (concatMap cDecl hsDecls) where
+    doNegate e = eAp (eAp (func_negate funcs) (typ e)) e
+    Identity funcs = fmapM (return . EVar . toTVr assumps) nameFuncNames
+
+    pval = convertVal assumps
+    cDecl :: HsDecl -> [(Name,TVr,E)]
+    cDecl (HsForeignDecl _ ForeignPrimitive s n _) = [(name,var, lamt (foldr ($) (EPrim (primPrim s) (map EVar es) rt) (map ELam es)))]  where
+        name = toName Name.Val n
+        var = tVr (nameToInt name) ty
+        (ty,lamt) = pval name
+        (ts,rt) = argTypes' ty
+        es = [ (tVr ( n) t) |  t <- ts, not (sortStarLike t) | n <- localVars ]
+    cDecl (HsForeignDecl _ ForeignCCall s n _)
+        | Func _ s _ _ <- p, not isIO =  expr $ createFunc dataTable [4,6..] (map tvrType es) $ \rs -> eStrictLet rtVar' (EPrim (APrim (Func False s (snds rs) rtt) req) [ EVar t | (t,_) <- rs ] rtt') (ELit $ LitCons cn [EVar rtVar'] rt')
+        | Func _ s _ _ <- p, "void" <- toExtType rt' = 
+                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> ELam tvrWorld $
+                    eStrictLet tvrWorld2 (EPrim (APrim (Func True s (snds rs) "void") req) (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit))
+        | Func _ s _ _ <- p = 
+                expr $ (createFunc dataTable [4,6..] (map tvrType es) $ \rs -> ELam tvrWorld $
+                    eCaseTup' (EPrim (APrim (Func True s (snds rs) rtt) req) (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO')  [tvrWorld2,rtVar'] (eLet rtVar (ELit $ LitCons cn [EVar rtVar'] rt') (eJustIO (EVar tvrWorld2) (EVar rtVar))))
+        --  | AddrOf _ <- p = expr $ EPrim (APrim p req) [] rt
+        | AddrOf _ <- p = let
+            (cn,st,ct) = runIdentity (lookupCType' dataTable rt)
+            (var:_) = freeNames (freeVars rt)
+            vr = tVr var st
+          in expr $ eStrictLet vr (EPrim (APrim p req) [] st) (ELit (LitCons cn [EVar vr] rt))
+        --  | otherwise = [(name,var, lamt (foldr ELam p' es))]
+        where
+        expr x = [(name,var,lamt x)]
+        Just (APrim p req) = parsePrimString s
+        name = toName Name.Val n
+        tvrWorld = tVr 256 tWorld__
+        tvrWorld2 = tVr 258 tWorld__
+        rtVar = tVr 260 rt'
+        rtVar' = tVr 262 rtt'
+        rttIO = ltTuple [tWorld__, rt']
+        rttIO' = ltTuple' [tWorld__, rtt']
+        (isIO,rt') = case  rt of
+            ELit (LitCons c [x] _) | show c == "Jhc.IO.IO" -> (True,x)
+            _ -> (False,rt)
+        toExtType e | Just (_,pt) <-  lookupCType dataTable e = pt
+        toExtType e = error $ "toExtType: " ++ show e
+        var = tVr (nameToInt name) ty
+        (ty,lamt) = pval name
+        (ts,rt) = argTypes' ty
+        es = [ (tVr ( n) t) |  t <- ts, not (sortStarLike t) | n <- localVars ]
+        (cn,rtt',rtt) = case lookupCType' dataTable rt' of
+            Right x -> x
+            Left err -> error $ "Odd RetType foreign: " ++ err
+        {-
+        p' = case p of
+            --AddrOf _ -> EPrim (APrim p req) (map EVar es) rt
+            Func _ s _ _ -> let ep = EPrim (APrim (Func isIO s (map (toExtType . tvrType) es) (toExtType rt')) req)  in case isIO of
+                False -> error "false"
+                --False -> ep (map EVar es) rt
+                --True | toExtType rt' /= "void" -> prim_unsafeCoerce (ELam tvrWorld $  eCaseTup  (ep (map EVar (tvrWorld:es))  rttIO) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))) rt
+                --     | otherwise -> prim_unsafeCoerce (ELam tvrWorld $ eStrictLet tvrWorld2 (ep (map EVar (tvrWorld:es))  tWorld__) (eJustIO (EVar tvrWorld2) vUnit)) rt
+                True | toExtType rt' /= "void" -> ELam tvrWorld $  eCaseTup  (ep (map EVar (tvrWorld:es))  rttIO) [tvrWorld2,rtVar] (eJustIO (EVar tvrWorld2) (EVar rtVar))
+                     | otherwise -> ELam tvrWorld $ eStrictLet tvrWorld2 (ep (map EVar (tvrWorld:es))  tWorld__) (eJustIO (EVar tvrWorld2) vUnit)
+                 --    | otherwise -> eStrictLet tvrWorld2 (ep (map EVar (tvrWorld:es))  tWorld__) (prim_unsafeCoerce (ELam tvrWorld $  eJustIO (EVar tvrWorld2) vUnit) rt)
+        -}
+    cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- simplifyHsPat p = let
+        name = toName Name.Val n
+        var = tVr (nameToInt name) ty -- lp ps (hsLet wh e)
+        (ty,lamt) = pval name
+        in [(name,var,lamt $ hsLetE wh (cRhs sl rhs))]
+    cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | ps' <- map simplifyHsPat ps, all isHsPVar ps' = [(name,var,lamt $ lp  ps' (hsLetE wh (cRhs sl rhs))) ] where
+        name = toName Name.Val n
+        var = tVr ( nameToInt name) ty -- lp ps (hsLet wh e)
+        (ty,lamt) = pval name
+    cDecl (HsFunBind ms@((HsMatch sl n ps _ _):_)) = [(name,v,lamt $ z $ cMatchs bs (matchesConv ms) (ump sl rt))] where
+        name = toName Name.Val n
+        v = tVr (nameToInt name) t -- lp ps (hsLet wh e)
+        (t,lamt) = pval name
+        (targs,eargs) = argTypes t
+        bs' = [(tVr (n) t) | n <- localVars | t <- take numberPatterns eargs]
+        bs  = map EVar bs'
+        rt = discardArgs (length targs + numberPatterns) t
+        numberPatterns = length ps
+        z e = foldr (eLam) e bs'
+    cDecl HsNewTypeDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCon = dcon, hsDeclDerives = derives } = makeDerives dname dargs [dcon] derives
+    cDecl HsDataDecl {  hsDeclName = dname, hsDeclArgs = dargs, hsDeclCons = dcons, hsDeclDerives = derives } = makeDerives dname dargs dcons derives
+    cDecl cd@(HsClassDecl {}) = cClassDecl cd
+    cDecl _ = []
+    makeDerives dname dargs dcons derives  = concatMap f derives where
+        f n | n == classBounded, all (null . hsConDeclArgs) dcons  = []
+        f _ = []
+    cExpr (HsAsPat n' (HsVar n)) = spec t t' $ EVar (tv n) where
+        (Forall _ (_ :=> t)) = getAssump n
+        Forall [] ((_ :=> t')) = getAssump n'
+--    cExpr (HsAsPat n' (HsCon n)) =  (ELit (LitCons (getName n) [] (ty t'))) where
+--        Forall [] ((_ :=> t')) = getAssump n'
+--    cExpr (HsAsPat n' (HsCon n v)) =  foldr ($)  (ELit (LitCons (getName n) (map EVar es) rt)) (map ELam es) where -- (spec t t' (cType n))) where
+--        (Forall _ (_ :=> t)) = gFalse n
+--        Forall [] ((_ :=> t')) = getAssump n'
+--        (ts,rt) = argTypes' (ty t')
+--        es = [ (TVr (Just n) t) |  t <- ts | n <- localVars ]
+    cExpr (HsAsPat n' (HsCon n)) =  foldr ($)  (ELit (LitCons (toName DataConstructor n) (map EVar es) rt)) (map ELam es) where -- (spec t t' (cType n))) where
+        (Forall _ (_ :=> t)) = getAssumpCon n
+        Forall [] ((_ :=> t')) = getAssump n'
+        (ts,rt) = argTypes' (ty t')
+        es = [ (tVr ( n) t) |  t <- ts | n <- localVars ]
+    cExpr (HsLit (HsString s)) = E.Values.toE s
+    cExpr (HsLit (HsInt i)) = intConvert i
+    --cExpr (HsLit (HsInt i)) | abs i > integer_cutoff  =  ELit (LitCons (toName DataConstructor ("Prelude","Integer")) [ELit $ LitInt (fromInteger i) (ELit (LitCons (toName RawType "intmax_t") [] eStar))] tInteger)
+    --cExpr (HsLit (HsInt i))  =  ELit (LitCons (toName DataConstructor ("Prelude","Int")) [ELit $ LitInt (fromInteger i) (ELit (LitCons (toName RawType "int") [] eStar))] tInt)
+    cExpr (HsLit (HsChar ch))  =  toE ch -- ELit (LitCons (toName DataConstructor ("Prelude","Char")) [ELit $ LitInt (fromIntegral $ ord i) (ELit (LitCons (toName RawType "uint32_t") [] eStar))] tChar)
+    cExpr (HsLit (HsFrac i))  =  toE i -- ELit $ LitInt (fromRational i) tRational -- LitFrac i (error "litfrac?")
+    cExpr (HsLambda sl ps e)
+        | all isHsPVar ps' =  lp ps' (cExpr e)
+        | otherwise = error $ "Invalid HSLambda at: " ++ show sl
+        where
+        ps' = map simplifyHsPat ps
+    cExpr (HsInfixApp e1 v e2) = eAp (eAp (cExpr v) (cExpr e1)) (cExpr e2)
+    cExpr (HsLeftSection op e) = eAp (cExpr op) (cExpr e)
+    cExpr (HsApp (HsRightSection e op) e') = eAp (eAp (cExpr op) (cExpr e')) (cExpr e)
+    cExpr (HsRightSection e op) = eLam var (eAp (eAp cop (EVar var)) ce)  where
+        (_,TVr { tvrType = ty}:_) = fromPi (typ cop)
+        var = (tVr ( nv) ty)
+        cop = cExpr op
+        ce = cExpr e
+        fvSet = (freeVars cop `Set.union` freeVars ce)
+        (nv:_) = [ v  | v <- localVars, not $  v `Set.member` fvSet  ]
+    cExpr (HsApp e1 e2) = eAp (cExpr e1) (cExpr e2)
+    cExpr (HsParen e) = cExpr e
+    cExpr (HsExpTypeSig _ e _) = cExpr e
+    cExpr (HsNegApp e) = (doNegate (cExpr e))
+    cExpr (HsLet dl e) = hsLet dl e
+    cExpr (HsIf e a b) = eIf (cExpr e) (cExpr a) (cExpr b)
+    cExpr (HsCase _ []) = error "empty case"
+    cExpr hs@(HsCase e alts) = z where
+        z = cMatchs [cExpr e] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs))  (typ z))
+    cExpr (HsTuple es) = eTuple (map cExpr es)
+    cExpr (HsAsPat n (HsList xs)) = cl xs where
+        cl (x:xs) = eCons (cExpr x) (cl xs)
+        cl [] = eNil (cType n)
+    --cExpr (HsAsPat _ e) = cExpr e
+    cExpr e = error ("Cannot convert: " ++ show e)
+    hsLetE [] e =  e
+    hsLetE dl e =  ELetRec [ (b,c) | (_,b,c) <- (concatMap cDecl dl)] e
+    hsLet dl e = hsLetE dl (cExpr e)
+
+    ty x = tipe x
+    kd x = kind x
+    cMatchs :: [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> E
+    cMatchs bs ms els = convertMatches funcs dataTable tv cType bs (processGuards ms) els
+
+    cGuard (HsUnGuardedRhs e) _ = cExpr e
+    cGuard (HsGuardedRhss (HsGuardedRhs _ g e:gs)) els = eIf (cExpr g) (cExpr e) (cGuard (HsGuardedRhss gs) els)
+    cGuard (HsGuardedRhss []) e = e
+
+    getAssumpCon n = case Map.lookup (toName Name.DataConstructor n) assumps of
+        Just z -> z
+        Nothing -> error $ "Lookup failed: " ++ (show n)
+    getAssump n = case Map.lookup (toName Name.Val n) assumps of
+        Just z -> z
+        Nothing -> error $ "Lookup failed: " ++ (show n)
+    tv n = toTVr assumps (toName Name.Val n)
+    lp  [] e = e
+    lp  (HsPVar n:ps) e = eLam (tv n) $ lp  ps e
+    lp  p e  =  error $ "unsupported pattern:" <+> tshow p  <+> tshow e
+    --cRhs sl rhs = g where g = cGuard rhs (ump sl $ typ g) --deliciously lazy
+    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) = eIf (cExpr g) (cExpr e) (f gs)
+        f [] = ump sl $ typ (cExpr e)
+    processGuards xs = [ (map simplifyHsPat ps,hsLetE wh . cGuard e) | (ps,e,wh) <- xs ]
+    spec g s e = ct (gg g s)  e  where
+        ct ts e = foldl eAp e $ map ty $ snds ts
+        gg a b = snubFst $ gg' a b
+        gg' (TAp t1 t2) (TAp ta tb) = gg' t1 ta ++ gg' t2 tb
+        gg' (TArrow t1 t2) (TArrow ta tb) = gg' t1 ta ++ gg' t2 tb
+        gg' (TCon a) (TCon b) = if a /= b then error "constructors don't match." else []
+        gg' _ (TGen _ _) = error "Something impossible happened!"
+        gg' (TGen n _) t = [(n,t)]
+        gg' (TVar a) (TVar b) | a == b = []
+        gg' a b = error $ "specialization: " <> parens  (show a) <+> parens (show b) <+> "in spec" <+> hsep (map parens [show g, show s, show e])
+    cType (n::HsName) = fst $ pval (toName Name.Val n)
+
+    cClassDecl (HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon name) _)) decls) = ans where
+        ds = map simplifyDecl decls
+        cr = findClassRecord classHierarchy name
+        ans = concatMap method [  n | n :>: _ <- classAssumps cr]
+        method n = return (defaultName,tVr ( nameToInt defaultName) ty,els) where
+            defaultName = toName Name.Val $ defaultInstanceName n
+            (TVr { tvrType = ty}) = tv n
+            els = case [ d | d <- ds, maybeGetDeclName d == Just n] of
+                [d] | [(_,_,v)] <- cDecl d -> v
+                -- []  -> EError ((show n) ++ ": no instance or default.") ty
+                []  -> EError "Bad" ty
+                _ -> error "This shouldn't happen"
+    cClassDecl _ = error "cClassDecl"
+
+
+ctgen t = map snd $ snubFst $ Seq.toList $ everything (Seq.<>) (mkQ Seq.empty gg) t where
+    gg (TGen n g) = Seq.single (n,g)
+    gg _ =  Seq.empty
+
+integer_cutoff = 500000000
+
+intConvert i | abs i > integer_cutoff  =  ELit (LitCons (toName DataConstructor ("Prelude","Integer")) [ELit $ LitInt (fromInteger i) (ELit (LitCons (toName RawType "intmax_t") [] eStar))] tInteger)
+intConvert i =  ELit (LitCons (toName DataConstructor ("Prelude","Int")) [ELit $ LitInt (fromInteger i) (ELit (LitCons (toName RawType "int") [] eStar))] tInt)
+
+--litconvert (HsInt i) t  =  LitInt (fromInteger i) t
+litconvert (HsChar i) t | t == tChar =  LitInt (fromIntegral $ ord i) tCharzh
+--litconvert (HsFrac i) t =  LitInt (fromRational i) t -- LitFrac 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
+
+convertMatches funcs dataTable tv cType bs ms err = evalState (match bs ms err) (20 + 2*length bs)  where
+    doNegate e = eAp (eAp (func_negate funcs) (typ e)) e
+    fromInt = func_fromInt funcs
+    fromInteger = func_fromInteger funcs
+    fromRational = func_fromRational funcs
+    match :: [E] -> [([HsPat],E->E)] -> E -> State Int E
+    match  [] ps err = f ps where
+        f (([],e):ps) = do
+            r <- f ps
+            return (e r)
+        f [] = return err
+        f _ = error "FromHs.convertMatches.match"
+    match _ [] err = return err
+    match (b:bs) ps err = f patternGroups err where
+        f  [] err = return err
+        f (ps:pss) err = do
+            err' <- f pss err
+            if isEVar err' || isEError err' then
+               g ps err'
+               else do
+                [ev] <- newVars [typ err']
+                nm <- g ps (EVar ev)
+                return $ eLetRec [(ev,err')] nm
+        g ps err
+            | all (not . isStrictPat) patternHeads = match bs [(ps',eLetRec (toBinding p) . e)  | (p:ps',e) <- ps] err
+            | any (isHsPAsPat || isHsPNeg || isHsPIrrPat) patternHeads = g (map (procAs b) ps) err
+            | Just () <- mapM_ fromHsPLitInt patternHeads = do
+                let tb = typ b
+                [bv] <- newVars [tb]
+                let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF (head . fst) ps]
+                    eq = EAp (func_equals funcs) tb
+                    f els (HsPLit (HsInt i),ps) = do
+                        --let ip = (EAp (EAp fromInt tb) (ELit (LitInt (fromIntegral i) tInt)))
+                        let ip | abs i > integer_cutoff  = (EAp (EAp fromInteger tb) (intConvert i))
+                               | otherwise =  (EAp (EAp fromInt tb) (intConvert i))
+                        m <- match bs ps err
+                        return $ eIf (EAp (EAp eq (EVar bv)) ip) m els
+                    f els (HsPLit (HsFrac i),ps) = do
+                        --let ip = (EAp (EAp fromInt tb) (ELit (LitInt (fromIntegral i) tInt)))
+                        let ip = (EAp (EAp fromRational tb) (toE i))
+                        m <- match bs ps err
+                        return $ eIf (EAp (EAp eq (EVar bv)) ip) m els
+                e <- foldlM f err gps
+                return $ eLetRec [(bv,b)] e
+            | all isHsPLit patternHeads = do
+                let gps = [ (p,[ (ps,e) |  (_:ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF (head . fst) ps]
+                    f (HsPLit l,ps) = do
+                        m <- match bs ps err
+                        return (Alt  (litconvert l (typ b)) m)
+                as@(_:_) <- mapM f gps
+                [TVr { tvrIdent = vr }] <- newVars [Unknown]
+                return $ unbox dataTable b vr $ \tvr -> eCase (EVar tvr) as err
+                --return $ eCase b as err
+            | all isHsPApp patternHeads = do
+                let gps =  sortGroupUnderF (hsPatName . head . fst) ps
+                    f (name,ps) = do
+                        let spats = hsPatPats $ head $ fst (head ps)
+                            nargs = length spats
+                        vs <- newVars (slotTypes dataTable (toName DataConstructor name) (typ b))
+                        ps' <- mapM pp ps
+                        m <- match (map EVar vs ++ bs) ps' err
+                        return (Alt (LitCons (toName DataConstructor name) vs (typ b))  m)
+                    --pp :: Monad m =>  ([HsPat], E->E) -> m ([HsPat], E->E)
+                    pp (HsPApp n ps:rps,e)  = do
+                        return $ (ps ++ rps , e)
+                as@(_:_) <- mapM f gps
+                return $ eCase b as err
+            | otherwise = error $ "Heterogenious list: " ++ show patternHeads
+            where
+            patternHeads = map (head . fst) ps
+        patternGroups = groupUnder (isStrictPat . head . fst) ps
+        procAs b (HsPNeg p:ps, ef) =  (p:ps,ef)  -- TODO, negative patterns
+        procAs b (HsPAsPat n p:ps, ef) =  (p:ps,eLetRec [((tv n),b)] . ef)
+        procAs b (HsPIrrPat p:ps, ef) =  (p:ps, ef) -- TODO, irrefutable patterns
+        procAs _ x = x
+        toBinding (HsPVar v) = [(tv v,b)]
+        toBinding (HsPNeg (HsPVar v)) = [(tv v,doNegate b)]
+        toBinding (HsPIrrPat p) = toBinding p
+        toBinding (HsPAsPat n p) = (tv n,b):toBinding p
+        toBinding p = error $ "toBinding: " ++ show p
+
+
+
+isStrictPat HsPVar {} = False
+isStrictPat (HsPNeg p) = isStrictPat p
+isStrictPat (HsPAsPat _ p) = isStrictPat p
+isStrictPat (HsPIrrPat p) = isStrictPat p  -- TODO irrefutable patterns
+isStrictPat _ = True
+
+
+--convertVMap vmap = Map.fromList [ (y,x) |  (x,y) <- Map.toList vmap]
+
+deNewtype :: DataTable -> E -> E
+deNewtype dataTable e = f e where
+    f (ELit (LitCons n [x] t)) | alias =  (f x)  where
+        Just Constructor { conAlias = alias } = getConstructor n dataTable
+    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons n [v] t) z):_) } | alias = eLet v (f e)  (f z) where
+        Just Constructor { conAlias = alias } = getConstructor n dataTable
+    f e = runIdentity $ emapE (return . f) e
+
+{-
+deNewtype :: DataTable -> E -> E
+deNewtype dataTable e = f e where
+    f (ELit (LitCons n [x] t)) | alias =  prim_unsafeCoerce (f x) t where
+        Just Constructor { conAlias = alias } = getConstructor n dataTable
+    f ECase { eCaseScrutinee = e, eCaseAlts =  ((Alt (LitCons n [v] t) z):_) } | alias = eLet v (prim_unsafeCoerce (f e) (getType v)) (f z) where
+        Just Constructor { conAlias = alias } = getConstructor n dataTable
+        --((nt:_),_) = argTypes' (typ z)
+    f e = runIdentity $ emapE (return . f) e
+--    f (ECase e ((PatLit ((LitCons n [_] t)),z):_)) | alias = EAp (f z) (EPrim "unsafeCoerce" [f e] nt) where
+--        Just Constructor { conAlias = alias } = getConstructor n dataTable
+--        ((nt:_),_) = argTypes' (typ z)
+
+-}
+
+{-
+
+toLC' :: Monad m => DataTable -> NameAssoc ->  ModEnv -> String -> m E
+toLC' dataTable nameAssoc mi wt = return $  eLetRec (theMain : (concatMap cClass (classRecords $ modEnvClassHierarchy mi)  ++ concatMap cDecl  decls)) (EVar theMainTvr)  where
+    decls = concat [ hsModuleDecls $ modInfoHsModule m | m <- Map.elems (modEnvModules mi) ] ++ Map.elems (modEnvLiftedInstances mi)
+    assumps = modEnvAllAssumptions mi -- `plusFM` modEnvDConsAssumptions mi
+    theMainTvr =  TVr (Just $ nameToInt theMainName) (typ (snd theMain))
+    --theMain = (theMainTvr,case ioLike  of Just x ->  EAp (EAp runMain  x ) (EVar tvm) ; Nothing -> EVar tvm)  where
+    theMain = (theMainTvr,case ioLike  of Just x ->  EAp (EAp runMain  x ) (EVar tvm) ; Nothing ->  EAp (EAp runExpr ty) (EVar tvm))  where
+        tvm@(TVr _ ty ) =  main
+        ioLike = case smplE ty of
+            ELit (LitCons n [x] _) -> if show n ==  "Jhc.IO.IO" then Just x else Nothing
+            _ -> Nothing
+    --nameToInt n = case Map.lookup n nameAssoc of
+    --    Nothing -> error $ "Not found: " ++ show n
+    --    Just z -> z
+
+    main = toTVr (parseName Val wt)
+    negate  = EVar $ toTVr (toName Val ("Prelude","negate"))
+    runMain = EVar $ toTVr (toName Val ("Prelude.IO","runMain"))
+    runExpr = EVar $ toTVr (toName Val ("Prelude.IO","runExpr"))
+
+
+    --tv n = TVr (zm (Left n)) (cType n)
+    --cClass :: (HsName,([Class], [Qual Pred], [Assump])) -> [(TVr,E)]
+    cClass :: ClassRecord -> [(TVr,E)]
+    cClass ClassRecord { className = name, classInsts = is, classAssumps = as } =  concat [ method n | n :>: _ <- as ] where
+        method n = return (tv n, v) where
+            els = case [ d | d <- ds, maybeGetDeclName d == Just n] of
+                [d] | [(_,v)] <- cDecl d -> eAp v (EVar tvr)
+                []  -> EError ((show n) ++ ": no instance or default.") t
+                _ -> error "This shouldn't happen"
+            --v = if null as then
+            --     snd $ head $ head [ cDecl d | d <- ds, maybeGetDeclName d == Just n]
+            --            else eLam tvr (eCase (EVar tvr) as els)
+            v = eLam tvr (eCase (EVar tvr) as els)
+            as = [(valToPat [] ( ty t), (EVar $ toTVr name)) | (_ :=> IsIn _ t ) <- is, let name =(toName Name.Val (instanceName n (getTypeCons t))), isJust $ Map.lookup name  assumps ] -- ++ [(valToPat [] ( ty t), (EVar $ toTVr name)) | (_ :=> IsIn _ t ) <- is, let name =(toName Name.Val (instanceName n (getTypeCons t))), isJust $ Map.lookup name  assumps ]
+            (EPi tvr@(TVr _ _) t) = cType n
+            valToPat xs (ELit (LitCons x ts t)) = PatLit $ LitCons x (replicate (length ts) Unknown)  (foldr EPi t xs)
+            valToPat _ e = errorDoc $ text "valToPat:" <+> ePretty e
+            --valToPat xs (ELam tvr e) = valToPat (tvr:xs) e
+            --valToPat xs (EAp (ELam tvr b) e) = valToPat xs (subst tvr e b)
+        [ds] = [ map simplifyDecl decls | (HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon n) _)) decls)  <- decls, n == name]
+
+
+    --pvalCache =   Map.fromList $ map (\x -> let y = toName Name.Val x in (y,pval' y)) $ lefts vars
+    --pval n = case Map.lookup  (toName Name.Val n) pvalCache of
+    --    Just z -> z
+     --   Nothing -> error $ "pval Lookup failed: " ++ (show n)
+    ft n = snd $ pval (toName Name.Val n)
+    --specialize a quantified type to a specific one by applying the expression to types
+    ty (TAp t1 t2) = eAp (ty t1) (ty t2)
+    ty (TArrow t1 t2) =  EPi (TVr Nothing (ty t1)) (ty t2)
+    ty (TCon (Tycon n k)) =  ELit (LitCons (toName TypeConstructor n) [] (kd k))
+--    ty (TCon (Tycon n k)) = foldr ($) (ELit (LitCons (getName n) (map EVar es) rt)) (map ELam es) where
+--        (ts,rt) = argTypes' (kd k)
+--        es = [ (TVr (Just n) t) |  t <- ts | n <- localVars ]
+    ty (TVar (Tyvar _ n k)) = EVar (TVr (lt n) (kd k))
+    ty (TGen _ (Tyvar _ n k)) = EVar (TVr (lt n) (kd k))
+
+
+        --gg' _ _ = []
+
+createMethods :: Monad m => ClassHierarchy -> (Map.Map Name (TVr,E))  -> m [(Name,TVr,E)]
+createMethods classHierarchy funcs = return ans where
+    ans = concatMap cClass (classRecords classHierarchy)
+    --cClass ClassRecord { className = name, classInsts = is, classAssumps = as } =  concat [ method n | n :>: _ <- as ]
+    cClass classRecord =  [ method classRecord n | n :>: _ <- classAssumps classRecord ]
+
+    method classRecord n = (methodName ,TVr ( nameToInt methodName) ty,v) where
+        methodName = toName Name.Val n
+        Just (deftvr@(TVr _ ty),_) = findName (toName Name.Val (defaultInstanceName n))
+        els = eAp (EVar deftvr) (EVar tvr)
+        --els = case [ d | d <- ds, maybeGetDeclName d == Just n] of
+        --    [d] | [(_,v)] <- cDecl d -> eAp v (EVar tvr)
+        --    []  -> EError ((show n) ++ ": no instance or default.") t
+        --    _ -> error "This shouldn't happen"
+        --v = if null as then
+        --     snd $ head $ head [ cDecl d | d <- ds, maybeGetDeclName d == Just n]
+        --            else eLam tvr (eCase (EVar tvr) as els)
+        v = eLam tvr (eCase (EVar tvr) as els)
+        --as = [Alt (valToPat [] (tipe t)) ((EVar $ fst $ runIdentity $ findName name)) | (_ :=> IsIn _ t ) <- classInsts classRecord, let name =(toName Name.Val (instanceName n (getTypeCons t))), isJust $ findName name ] -- ++ [(valToPat [] ( ty t), (EVar $ toTVr name)) | (_ :=> IsIn _ t ) <- is, let name =(toName Name.Val (instanceName n (getTypeCons t))), isJust $ Map.lookup name  assumps ]
+        as = [calt (tipe t) (fst $ runIdentity $ findName name) | (_ :=> IsIn _ t ) <- classInsts classRecord, let name =(toName Name.Val (instanceName n (getTypeCons t))), isJust $ findName name ] -- ++ [(valToPat [] ( ty t), (EVar $ toTVr name)) | (_ :=> IsIn _ t ) <- is, let name =(toName Name.Val (instanceName n (getTypeCons t))), isJust $ Map.lookup name  assumps ]
+        (EPi tvr@(TVr _ _) t) = ty
+        calt (ELit (LitCons x vs t)) tvr =  Alt (LitCons x [ tvr | ~(EVar tvr) <- vs ]  t) (foldl EAp (EVar tvr) vs)
+        --valToPat xs (ELit (LitCons x ts t)) = PatLit $ LitCons x (replicate (length ts) Unknown)  (foldr EPi t xs)
+        valToPat [] (ELit (LitCons x [] t)) =  LitCons x []  t
+        valToPat [] (ELit (LitCons x vs t)) =  LitCons x [ tvr | ~(EVar tvr) <- vs ]  t
+        --valToPat xs (ELit (LitCons x ts t)) =  LitCons x (replicate (length ts) Unknown)  (foldr EPi t xs)
+        valToPat [] e = errorDoc $ text "valToPat:" <+> ePretty e
+        --valToPat xs (ELam tvr e) = valToPat (tvr:xs) e
+        --valToPat xs (EAp (ELam tvr b) e) = valToPat xs (subst tvr e b)
+    --nameMap = Map.fromList [ (n,(t,e)) |  (n,t,e) <- funcs]
+    findName name = case Map.lookup name funcs of
+        Nothing -> fail $ "Cannot find: " ++ show name
+        Just n -> return n
+-}
+
+
addfile ./E/Inline.hs
hunk ./E/Inline.hs 1
+--module E.Inline(TravM, newVarName, lookupBinding, newBinding, traverse,Binding(..),emapE,emapE', TravOptions(..),travOptions ) where
+module E.Inline(inlineDecompose, basicDecompose, emapE, emapE',emapEG,emapE_) where
+
+
+import E.E
+import E.Rules
+import E.Values
+
+import Control.Monad.Writer
+import Data.Monoid
+import GraphUtil
+import HasSize
+import FreeVars
+import GenUtil
+import Data.FunctorM
+import qualified Data.Set as Set
+
+
+
+-- To decide whether to inline, we take a few things into account 
+
+                       
+baseInlinability e 
+    | isAtomic e = 5
+    | whnfOrBot e = 4 
+    | otherwise = 0
+
+basicDecompose :: 
+    Maybe [Int]  -- ^ Just a set of values not to prune or nothing to not prune at all.
+    -> Rules     -- ^ Rules for pruning
+    -> E             -- ^ body for pruning info
+    -> [(TVr,E)]     -- ^ incoming bindings
+    -> [Either (TVr,E) [(TVr,E)]]     -- ^ bindings pruned and ordered by inlinability value
+basicDecompose prune rules body ds = ans where
+    zs = [ ((t,e), tvrNum t, freeVars (tvrType t) `mappend` freeVars e `mappend` Set.toList (ruleFreeVars rules t)) |  (t,e) <- ds ]
+    cg zs =  newGraph zs (\ (_,x,_) -> x) ( \ (_,_,x) -> x) 
+    tg = cg zs
+    scc' = scc tg 
+    scc'' = case prune of 
+        Nothing -> scc'
+        Just s -> scc $ cg $ reachable tg (freeVars body ++ s )
+    ans = mapScc f scc''
+    f (v,_,_) = v
+    mapScc f = map g where
+        g (Left x) = Left (f x)
+        g (Right xs) = Right (map f xs)
+
+
+inlineDecompose :: 
+    Maybe [Int]  -- ^ Just a set of values not to prune or nothing to not prune at all.
+    -> E             -- ^ body for pruning info
+    -> [(TVr,E)]     -- ^ incoming bindings
+    -> [(TVr,E)]     -- ^ bindings pruned and ordered by inlinability value
+inlineDecompose prune body ds = ans where
+    zs = [ ((t,e), tvrNum t, freeVars e, inlinability e) |  (t,e) <- ds ]
+    cg zs =  newGraph zs (\ (_,x,_,_) -> x) ( \ (_,_,x,_) -> x) 
+    tg = cg zs
+    scc' = scc tg 
+    scc'' = case prune of 
+        Nothing -> scc'
+        Just s -> scc $ cg $ reachable tg (freeVars body ++ s )
+    inlinability e = baseInlinability e - size (fst $ fromLam e)   
+    ans = f scc'' []
+    f (Left (v,_,_,_):ds) xs = f ds (v:xs)
+    f (Right ms:ds) xs = f (scc' ++ ds) xs where
+        scc' = scc (cg [ (a,b,filter (/= i) c,d) | (a,b,c,d) <- ms])
+        (_,i,_,_) = minimumUnder (\ (_,_,_,x) -> x) ms
+    f [] xs = reverse xs
+
+ 
+    
+{-
+inlineDecompose prune body ds = ans where
+    zs = [ ((t,e), tvrNum t, freeVars e, inlinability e) |  (t,e) <- ds ]
+    --tg = newGraph zs (\ (_,x,_,_) -> x) ( \ (_,_,x,_) -> x) 
+    scc = stronglyConnComp [ (x,a,b) | x@(_,a,b,_) <- zs ]
+    inlinability e = baseInlinability e - size (fst $ fromLam e)   
+    ans = f scc []
+    f (AcyclicSCC (v,_,_,_):ds) xs = f ds (v:xs)
+    f (CyclicSCC ms:ds) xs = f (scc' ++ ds) xs where
+        scc' = stronglyConnComp [ (x,a,filter (/= i) b) | x@(_,a,b,_) <- ms ]
+        (_,i,_,_) = minimumUnder (\ (_,_,_,x) -> x) ms
+    f [] xs = reverse xs
+
+emapE f (EAp aa ab) = do aa <- f aa;ab <- f ab; return $ EAp aa ab
+emapE f (ELam aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ ELam aa ab
+emapE f (EPi aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ EPi aa ab
+--emapE f (EVar aa) = do aa <- mapmTvr f aa; return $ EVar aa
+emapE f (EVar aa) = do return $ EVar aa
+emapE f (Unknown) = do return $ Unknown
+emapE f (ESort aa) = do return $ ESort aa
+emapE f (ELit aa) = do aa <- litSMapM f aa; return $ ELit aa
+emapE f (ELetRec aa ab) = do aa <- mapM (\x -> do x <- (do (aa,ab) <- return x; aa <- mapmTvr f aa;ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab
+emapE f (ECase e b as d) = do
+    e' <- f e
+    b' <- fmapM f b
+    as' <- mapmAlt as 
+    d' <- fmapM f d
+    return (ECase e' b' as' d')
+--    aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- fmapM f x; y <- f y; return (x,y)) ab; return $ ECase aa ab
+emapE f (EPrim aa ab ac) = do ab <- mapM f ab;ac <- f ac; return $ EPrim aa ab ac
+emapE f (EError aa ab) = do ab <- f ab; return $ EError aa ab
+
+
+-- do not traverse into types
+emapE' f (EAp aa ab) = do aa <- f aa;ab <- f ab; return $ EAp aa ab
+emapE' f (ELam aa ab) = do ab <- f ab; return $ ELam aa ab
+emapE' f (EPi aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ EPi aa ab
+--emapE' f (EPi aa ab) = do  ab <- f ab; return $ EPi aa ab
+emapE' f (EVar aa) = do return $ EVar aa
+emapE' f (Unknown) = do return $ Unknown
+emapE' f (ESort aa) = do return $ ESort aa
+emapE' f (ELit (LitCons a es e)) = do es <- mapM f es;  return $ ELit (LitCons a es e)
+emapE' f (ELit aa) = do aa <- fmapM f aa; return $ ELit aa
+emapE' f (ELetRec aa ab) = do aa <- mapM (\x -> do x <- (do (aa,ab) <- return x; ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab
+emapE' f (ECase e b as d) = do
+    e' <- f e
+    as' <- mapmAlt' as 
+    d' <- fmapM f d
+    return (ECase e' b as' d')
+--emapE' f (ECase aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- patFmap' f x; y <- f y; return (x,y)) ab; return $ ECase aa ab
+emapE' f (EPrim aa ab ac) = do ab <- mapM f ab; return $ EPrim aa ab ac
+emapE' f (EError aa ab) =  return $ EError aa ab
+
+mapmTvr f (TVr x e) = f e >>= return . TVr x 
+mapmAlt f (Alt l e) = do
+    e' <- f e
+    l' <- litSMapM f l
+    return (Alt l' e')
+mapmAlt' f (Alt l e) = do
+    e' <- f e
+    return (Alt l e')
+
+
+--patFmap' f PatWildCard = return PatWildCard
+--patFmap' f (PatLit l) = litFmap' f l >>= return . PatLit
+litFmap' f (LitCons a es e) = do es <- mapM f es; return $ (LitCons a es e)
+litFmap' _ l = return l
+
+-}
+
+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 = 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 f aa; return $ EVar aa
+    z (Unknown) = do return $ Unknown
+    z (ESort aa) = do return $ ESort aa
+    z (ELit (LitCons n es t)) = do t' <- g t; es' <- mapM f es; return $ ELit (LitCons n es' t')
+    z (ELit aa) = do aa <- fmapM g aa; return $ ELit aa
+    z (ELetRec aa 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 (ECase e b as d) = do
+        e' <- f e
+        b' <- fmapM g b
+        as' <- mapM mapmAlt as 
+        d' <- fmapM f d
+        return (ECase e' b' as' d')
+    --    aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- fmapM f x; y <- f y; return (x,y)) ab; return $ ECase aa ab
+    z (EPrim aa ab ac) = do ab <- mapM f ab;ac <- f ac; return $ EPrim aa ab ac
+    z (EError aa ab) = do ab <- f ab; return $ EError aa ab
+    mapmTvr = fmapM
+    mapmAlt (Alt (LitCons n xs t) e) = do
+        e' <- f e
+        xs' <- mapM (fmapM g) xs
+        t' <- g t
+        return $ Alt (LitCons n xs' t') e'
+    mapmAlt (Alt l e) = do
+        e' <- f e
+        l' <- fmapM g l
+        return (Alt l' e')
+
+
+instance Monoid Int where
+    mempty = 0
+    mappend = (+)
+    mconcat = sum 
+
+instance HasSize E where
+    size = eSize
+    
+eSize :: E -> Int
+eSize e = n where
+    (_, n) = runWriter (f e) 
+    f e@ELit {} = tell 1 >> return e
+    f e@EPrim {} = tell 1 >> return e
+    f e@EError {} = tell 1 >> return e
+    f e = tell ( 1) >> emapE' f e
+
addfile ./E/LambdaLift.hs
hunk ./E/LambdaLift.hs 1
+module E.LambdaLift(SC(..), scToE, eToSC, lambdaLift, lambdaLiftE)  where
+
+import Atom
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.IORef
+import E.E
+import E.Subst
+import DataConstructors
+import E.Traverse
+import E.TypeCheck
+import FreeVars
+import GenUtil
+import GraphUtil as G
+import Name
+import qualified Data.Set as Set
+import Stats
+import UniqueMonad
+import List
+import Data.FunctorM
+
+
+-- super combinators
+data SC = SC { scMain :: TVr, scCombinators ::  [(TVr,[TVr],E)] }
+    deriving(Eq,Show)
+
+scToE :: SC -> E
+scToE (SC v ds) = ELetRec ds' (EVar v) where
+    ds' = sortLetDecls [ (t,foldr ELam e as) |  (t,as,e) <- ds]
+
+eToSC :: DataTable -> E -> SC
+eToSC _ (ELetRec ds (EVar v)) = SC v ds' where
+    ds' = [ (a,b,c) | (a,(c,b)) <- [ (t,fromLam e) | (t,e) <- ds ]] 
+eToSC dt (ELetRec ds e) = SC tvr ((tvr,as,e'):ds') where 
+    (e',as) = fromLam e
+    tvr = (tVr num (typeInfer dt e))
+    --num = -2
+    Just num = List.find (`notElem` [ n  | (TVr { tvrIdent = n },_) <- ds ]) [200000,200002 ..]
+    ds' = [ (a,b,c) | (a,(c,b)) <- [ (t,fromLam e) | (t,e) <- ds ]] 
+eToSC dt v = SC tvr [(tvr,as,e')] where
+    (e',as) = fromLam v
+    tvr = (tVr num (typeInfer dt v))
+    num = 200000
+-- eToSC (ELetRec ds v) = error $ "eToSC: " ++ show v
+
+-- | pull lets from just in definitions to top level, as they can obscure lambdas. 
+flattenSC :: SC -> SC
+flattenSC (SC v cs) = SC v (concatMap f cs) where
+    f (t,[],ELetRec ds e) = fd (t,e):map fd ds 
+    f (t,as,e) = [(t,as,e)]
+    fd (t,e) =  let (c,b) = fromLam e in (t,b,c)
+
+lambdaLiftE stats dt e = fmap scToE (lambdaLift stats dt (eToSC dt e))
+
+data S = S { funcName :: Atom, topVars :: Set.Set Int, isStrict :: Bool, declEnv :: [(TVr,E)] }
+    {-! derive: update !-}
+
+etaReduce :: E -> (E,Int)
+etaReduce (ELam t (EAp x (EVar t'))) | t == t' && not (tvrNum t `Set.member` freeVars x) = case etaReduce x of
+    (x',i) -> (x',i + 1)
+etaReduce e = (e,0)
+
+lambdaLift :: Stats -> DataTable -> SC -> IO SC 
+lambdaLift stats dataTable sc = do
+    let SC m cs = sc -- flattenSC sc
+    let wp =  Set.fromList [ tvrNum x | (x,_,_) <- cs ]
+    fc <- newIORef []
+    let z (n,as,v) = do
+            let ((v',cs'),stat) = runReader (runStatT $ execUniqT 1 $ runWriterT (f v)) S { funcName = (intToAtom' (tvrNum n)), topVars = wp,isStrict = True, declEnv = [] }
+            tickStat stats stat
+            modifyIORef fc (\xs -> (n,as,v'):cs' ++ xs)
+        f e@(ELetRec ds _)  = do 
+            local (declEnv_u (ds ++)) $ do
+                let (ds',e') = decomposeLet e
+                h (concatMap G.fromScc ds') e' []
+        f e = do 
+            st <- asks isStrict 
+            if (isELam e || (shouldLift 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 (ECase (EVar v) b as d) | sortStarLike (tvrType v) = do
+            True <- asks isStrict 
+            d' <- fmapM f d 
+            let z (Alt l e) = do
+                    e' <- local (declEnv_u ((v,patToLitEE l):)) $ f e 
+                    return $ Alt l e'
+            as' <- mapM z as 
+            return $ ECase (EVar v) b as' d'
+        g e = emapE' f e
+        pLift e = do
+            gs <- asks topVars
+            ds <- asks declEnv
+            let fvs = freeVars e 
+                fvs' = filter (not . (`Set.member` gs) . tvrNum) fvs
+                ss = filter (sortStarLike . tvrType) fvs'
+                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' tvrNum freeVars 
+            f ss e False
+        h ((t,e):ds) rest ds' | shouldLift 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 ((t,e):ds) rest ds'  = do
+            let fvs =  freeVars e 
+            gs <- asks topVars
+            let fvs' = filter (not . (`Set.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 ((t,e):ds) e' ds' = local (isStrict_s False) (f e) >>= \e'' -> h ds e' ((t,e''):ds') 
+        h [] e ds = f e >>= return . eLetRec ds 
+        shouldLift EError {} = True
+        shouldLift ECase {} = True
+        shouldLift ELam {} = True
+        shouldLift _ = False
+        doLift t e r = local (topVars_u (Set.insert (tvrNum t)) ) $ do
+            (e,tn) <- return $ etaReduce e
+            let (e',ls) = fromLam e 
+            mtick (toAtom $ "E.LambdaLift.doLift." ++ show (length ls))
+            mticks tn (toAtom $ "E.LambdaLift.doLift.etaReduce")
+            e'' <- local (isStrict_s True) $ f e'
+            tell [(t,ls,e'')]
+            r
+        newName tt = do
+            un <-  newUniq
+            n <- asks funcName
+            return $ tVr (atomIndex (n `mappend` toAtom '$' `mappend` toAtom (show  un))) tt 
+        doBigLift e fs  dr = do
+            mtick (toAtom $ "E.LambdaLift.doBigLift." ++ 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' 
+            tell [(tvr,fs ++ ls,e'')]
+            let e'' = foldl EAp (EVar tvr) (map EVar fs)
+            dr e''
+            
+        intToAtom' x = case intToAtom x of
+            Just y -> y
+            Nothing -> toAtom $ toName Val ("LL@",'f':show x)
+    mapM_ z cs
+    ncs <- readIORef fc 
+    return $ SC m ncs
+            
+            
+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) }  
+    
+
+
+
+
+--        h ((t,e):ds) rest ds' | shouldLift e = do
+--            let fvs =  freeVars e 
+--            gs <- asks topVars
+--            let fvs' = filter (not . (`Set.member` gs) . tvrNum) fvs
+--                fvs'' = reverse $ topSort $ newGraph fvs' tvrNum freeVars 
+--            case fvs'' of
+--                [] -> doLift t e (h ds rest ds')
+--                fs -> doBigLift e fs (\e'' -> h ds rest ((t,e''):ds'))
+    
+
+--        f e = do 
+--            st <- asks isStrict 
+--            if (isELam e || (shouldLift e && not st)) then do
+--                let (fvs :: [TVr]) = freeVars e 
+--                (gs :: Set.Set Int) <- asks topVars
+--                let fvs' = filter (not . (`Set.member` gs) . tvrNum) fvs
+--                    fvs'' = reverse $ topSort $ newGraph fvs' tvrNum freeVars 
+--                doBigLift e fvs'' return
+--             else emapE' f e
+
addfile ./E/LetFloat.hs
hunk ./E/LetFloat.hs 1
+module E.LetFloat(
+    atomizeApps,
+    coalesceLets,
+    annotateBindings,
+    doCoalesce,
+    doLetRec,
+    varElim,
+    propRec,
+    floatInward
+  ) where
+
+
+import Atom
+import Control.Monad.Writer
+import Data.Monoid
+import DDataUtil()
+import E.E
+import E.Inline
+import E.Traverse
+import E.Values
+import E.Rules
+import FreeVars
+import GenUtil
+import GraphUtil
+import List
+import qualified GraphUtil as G
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import SameShape
+import Stats
+import E.SSimplify(app)
+import Control.Monad.Identity
+
+
+
+doLetRec stats [] e = return e
+doLetRec stats ds e = do
+    return $ ELetRec ds e
+    {-
+    let fakeDs = (TVr (-1) undefined,e)
+    let ds' = reachable (newGraph (fakeDs:ds) (tvrNum . fst) (freeVars . snd)) [-1]
+    let ds'' = [ d | d@(t,_) <- ds', tvrNum t /= -1 ]
+    liftIO $ ticks stats (length ds - length ds'') (toAtom "E.LetFloat.var-elimination")
+    return $ ELetRec ds'' e
+    -}
+
+varElim :: Stats -> Int -> IO ()
+varElim stats n = do
+    ticks stats n (toAtom "E.Simplify.var-elimination")
+propRec stats n = do
+    ticks stats n (toAtom "E.Simplify.copy-propegate")
+
+atomizeApps :: Stats -> E -> IO E
+atomizeApps stats e = traverse travOptions { pruneRecord = varElim stats } f mempty mempty e where
+    --f 0 (EPi (TVr Nothing t) b,[])  = do
+    --    (t',ds1) <- at t
+    --    (b',ds2) <- at b
+    --    doLetRec stats
+    f 0 (EPrim n xs t,[]) = do
+        (xs',dss) <- fmap unzip (mapM at xs)
+        doLetRec stats (concat dss) (EPrim n xs' t)
+    f 0 (ELit (LitCons n xs t),[]) = do
+        (xs',dss) <- fmap unzip (mapM at xs)
+        doLetRec stats (concat dss) (ELit (LitCons n xs' t))
+    f n (x,xs) | n > 0 ||  all (isAtomic) xs = return $ foldl EAp x xs
+    f 0 (x,xs) = do
+        (xs',dss) <- fmap unzip (mapM at xs)
+        doLetRec stats (concat dss) (foldl EAp x xs')
+    at e | not (isAtomic e) = do
+        --lift $ putErrLn $ "Atomizing: " ++ render (ePretty e)
+        e <- f 0 (e,[])
+        lift $ tick stats (toAtom "E.LetFloat.atomizeApps")
+        nb@(tvr,_) <- newBinding e
+        return (EVar tvr,[nb])
+    at e = return (e,[])
+
+doCoalesce :: Stats -> (E,[E]) -> IO (E,[E])
+doCoalesce stats (x,xs) = ans where
+    ans = do
+        (xs',dss) <- fmap unzip (mapM at xs)
+        case x of
+            ELetRec ds' (ELetRec ds'' x') -> do
+                liftIO $ tick stats (toAtom "E.LetFloat.coalesce.fromLet")
+                fromLet2 (concat $ ds'':ds':dss) (foldl EAp x' xs')
+            ec@ECase { eCaseScrutinee = (ELetRec ds' x') }  -> do
+                liftIO $ tick stats (toAtom "E.LetFloat.coalesce.fromCase")
+                fromLet2 (concat $ ds':dss) (foldl EAp (ec { eCaseScrutinee = x' } ) xs')
+            ELetRec ds' x' | not (null xs) -> do
+                liftIO $ tick stats (toAtom "E.LetFloat.coalesce.fromAp")
+                fromLet2 (concat $ ds':dss) (foldl EAp x' xs')
+            ELetRec ds x' -> do
+                fromLet2 (concat $ ds:dss) (foldl EAp x' xs')
+            x -> fromLet2 (concat dss) (foldl EAp x xs')
+    at (ELetRec ds e) = do
+        liftIO $ tick stats (toAtom "E.LetFloat.coalesce.fromArg")
+        return (e,ds)
+    at e = return (e,[])
+    --at' (t,(ELetRec ds e)) = do
+    --    liftIO $ tick stats (toAtom "E.LetFloat.coalesce.fromLet2")
+    --    return ((t,e),ds)
+    at' e = return (e,[])
+    fromLet2 ds e = do
+        (ds',dss) <- fmap unzip (mapM at' ds)
+        let ds'' = (concat $ ds':dss)
+        r <- doLetRec stats ds''  e
+        return $ fromAp r
+
+fvBind (Left (_,fv)) = fv
+fvBind (Right xs) = Set.unions (snds xs)
+
+
+--    f (ELetRec ds e) xs = g (G.scc $  G.newGraph [ (d, freeVars (tvrType $ fst d) `mappend` freeVars' (fst d) (snd d))  | d <- ds ] (tvrNum . fst . fst) (Set.toList . snd) ) xs where
+
+
+floatInward ::
+    Rules -- ^ rules to augment free variables of definitons
+    -> E  -- ^ input term
+    -> E  -- ^ output term
+floatInward rules e = f e [] where
+    --freeVars' v e = freeVars e `mappend` ruleFreeVars rules v
+    freeVars' v e = augment (freeVars (tvrType v) `mappend` freeVars e)
+    augment fvs = mconcat (fvs:[ ruleFreeVars' rules x | x <- Set.toList fvs ])
+    f (ECase e b as d) xs = letRec p' $ ECase (f e pe) b [ Alt l (f e pn) | Alt l e <- as | pn <- ps ] (fmap (flip f pd) d)  where
+        (p',_:pe:pd:ps) = sepByDropPoint (mconcat [freeVars l | Alt l _ <- as ]:freeVars e: tvrNum b `Set.delete` freeVars d :[freeVars a | a <- as ]) xs
+    f (ELetRec ds e) xs = g (G.scc $  G.newGraph [ (d,freeVars' x y) | d@(x,y) <- ds ] (tvrNum . fst . fst) (Set.toList . snd) ) xs where
+        g [] p' = f e p'
+        g ((Left ((v,ev),fv)):xs) p = g xs (p0 ++ [Left ((v,ev'),freeVars' v ev')] ++ p') where
+            ev' = f ev pv
+            (p',[p0,pv,_]) = sepByDropPoint [augment (frest xs), freeVars' v ev, freeVars (tvrType v)] p
+        g (Right bs:xs) p =  g xs (p0 ++ [Right [ let ev' = f ev pv in ((v,ev'),freeVars' v ev') | ((v,ev),_) <- bs | pv <- ps ]] ++ p') where
+            (p',_:p0:ps) = sepByDropPoint (freeVars (map (tvrType . fst . fst) bs) :augment (frest xs):snds bs) p
+        frest xs = mconcat (freeVars e:map fvBind xs)
+    f e xs |  not (null ls) = letRec unsafe_binds (foldr ELam (f b safe_binds) ls) where
+        (unsafe_binds,safe_binds) =  sepDupableBinds (freeVars $ map tvrType ls) xs
+        (b,ls) = fromLam e
+    f e (Left ((v',ev),_):xs)
+        | (EVar v,as) <- fromAp e, v == v', tvrNum v' `notElem` freeVars as  = f (runIdentity $ app (ev,as) {- foldl EAp ev as -} ) xs
+    --    | otherwise = f (EVar v) xs
+    --    | otherwise = error $ "floatInward: shouldn't happen:" <+>  tshow (EVar v) <+> tshow (v')
+    f e xs = letRec xs e
+    letRec [] e = e
+    letRec xs e = f (G.scc $ G.newGraph (concatMap fromScc xs) (tvrNum . fst . fst) (Set.toList . snd)) where
+        f [] = e
+        f (Left (te,_):rs) = eLetRec [te] $ f rs
+        f (Right ds:rs) = eLetRec (fsts ds) $ f rs
+    --letRec p e = eLetRec  (concatMap (map fst . fromScc) p) e
+    --letRec p e = foldr eLetRec e (reverse $ map (map fst . fromScc) p)
+
+type FVarSet = Set.Set Int
+type Binds = [Either ((TVr,E),FVarSet) [((TVr,E),FVarSet)]]
+
+
+sepDupableBinds fvs xs = partition ind xs where
+    g = G.reachable (G.newGraph (concatMap fromScc xs) (tvrNum . fst . fst) (Set.toList . snd)) (fvs `mappend` (map (tvrNum . fst . fst) $ concatMap fromScc unsafe_ones))
+    uso = map (tvrNum . fst . fst) g
+    (_,unsafe_ones) = partition std xs
+    std (Left ((_,e),_)) = safeToDup e
+    std (Right zs) = all safeToDup (snds $ fsts zs)
+    ind x = any ( (`elem` uso) . tvrNum . fst . fst ) (fromScc x)
+
+sameLength [] [] = True
+sameLength (_:xs) (_:ys) = sameLength xs ys
+sameLength _ _ = False
+
+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
+    --fs =  ( G.scc $  G.newGraph (concatMap fromScc fs')  (tvrNum . fst . fst) (Set.toList . snd) )
+    (r,xs) = f fs'
+    f [] = ([], [ [] | _ <- ds ])
+    f (b:bs)
+        --  | nu == 0 = f bs -- not (any (`Set.member` allSet) (fvDecls b)) = f bs
+        | nu == 1 =   case sepByDropPoint [ if v then d `mappend` fb' else d | (d,v) <- ds'  ] bs of
+            (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'') | sameShape1 ds'' ds -> (b:gb,ds'')
+      where
+        fb' = fvBind b
+        fb = Set.toList $ fb'
+        ds' = [ (d,any  (`Set.member` d) (fvDecls b)) | d <- ds ]
+        nu = length (filter snd ds')
+    fvDecls (Left ((t,_),_)) = [tvrNum t]
+    fvDecls (Right ts) = [tvrNum t | ((t,_),_) <- ts ]
+    comb (a,b) (c,d) = (a ++ c, zipWith (++) b d)
+
+floatOutward :: Map.Map Int Int -> E -> (E,[(TVr,E)])
+floatOutward bmap e = (e,[])
+
+-- Beautiful use of lazyness.
+annotateBindings :: Map.Map TVr Int -> E -> Map.Map TVr Int
+annotateBindings min e = ans where
+    ans = min `mappend` execWriter (f 0 e)
+    f :: Int -> E -> Writer (Map.Map TVr Int) ()
+    f n ec@ECase {} = do
+        tell (Map.fromList [ (i,n) | i <- caseBinds ec ])
+        emapE_ (f n) ec
+    f n (ELetRec ds b) = do
+        let ds' = [ (t,freeVars e) | (t,e) <- ds]
+            scc = G.scc (G.newGraph ds' (tvrNum . fst) snd)
+            g (Left (t,fv)) = tell (Map.singleton t (maximum $ 0:[Map.findWithDefault 0 (tVr v Unknown) ans | v <- fv]))
+            g (Right ts) = do
+                let ln = maximum [Map.findWithDefault 0 (tVr v Unknown) ans | v <- (snub $ concat (snds ts))  List.\\ [ i | (TVr { tvrIdent = i },_) <- ts ] ]
+                tell (Map.fromList [ (t,ln) | (t,_) <- ts])
+        mapM_ g scc
+        mapM_ (f n) (snds ds)
+        f n b
+    f n e | (b,ls@(_:_)) <- fromPi e = do   -- not really necessary
+        tell (Map.fromList [ (i,n + 1) | i  <- ls ])
+        f (n + 1) b
+    f n e | (b,ls@(_:_)) <- fromLam e = do
+        tell (Map.fromList [ (i,n + 1) | i  <- ls ])
+        f (n + 1) b
+    f n e = emapE_ (f n) e
+
+
+coalesceLets :: Stats -> E -> IO E
+coalesceLets stats e = traverse travOptions { pruneRecord = varElim stats } f mempty mempty e where
+    f n (x,xs) = do
+        (x',xs') <- lift $ doCoalesce stats (x,xs)
+        return $ foldl EAp x' xs'
+    {-
+    f n (x,xs) = do
+        (xs',dss) <- fmap unzip (mapM at xs)
+        case x of
+            ECase (ELetRec ds' (ELetRec ds'' x')) as -> do
+                lift $ tick stats (toAtom "LetFloat.coalesce.fromLet")
+                fromLet2 (concat $ ds'':ds':dss) (foldl EAp x' xs')
+            ECase (ELetRec ds' x') as -> do
+                lift $ tick stats (toAtom "LetFloat.coalesce.fromCase")
+                fromLet2 (concat $ ds':dss) (foldl EAp (ECase x' as) xs')
+            ELetRec ds' x' | not (null xs) -> do
+                lift $ tick stats (toAtom "LetFloat.coalesce.fromAp")
+                fromLet2 (concat $ ds':dss) (foldl EAp x' xs')
+            x -> fromLet2 (concat dss) (foldl EAp x xs')
+    at (ELetRec ds e) = do
+        lift $ tick stats (toAtom "LetFloat.coalesce.fromArg")
+        return (e,ds)
+    at e = return (e,[])
+    at' (t,(ELetRec ds e)) = do
+        lift $ tick stats (toAtom "LetFloat.coalesce.fromLet2")
+        return ((t,e),ds)
+    at' e = return (e,[])
+    fromLet2 ds e = do
+        (ds',dss) <- fmap unzip (mapM at' ds)
+        doLetRec stats (concat $ ds':dss) e
+
+    -}
+
+letFloat :: Stats -> String -> E -> IO (E,[(TVr,E)])
+letFloat stats s e = do
+    return (e,[])
+
+--notAtomic e | Just _ <- fullyConst e = False
+--notAtomic e | sortTypeLike e = False
+--notAtomic e = not $ isAtomic e
+
+--notAtomic (ELetRec _ e) = notAtomic e
+----notAtomic x | sortTypeLike x  = False
+--notAtomic ECase {} = True
+--notAtomic EAp {} = True
+--notAtomic ELam {} = True
+--notAtomic EPrim {} = True
+--notAtomic e | Just _ <- fullyConst e = False
+--notAtomic (ELit (LitCons n (_:_) _)) = True
+--notAtomic EPi {} = True
+--notAtomic _ = False
+
addfile ./E/Pretty.hs
hunk ./E/Pretty.hs 1
+module E.Pretty(ePretty, ePrettyNEx, ePrettyEx, ePrettyN, prettyE, render ) where
+
+import E.E
+import E.Values
+import Doc.Pretty
+import Doc.DocLike
+import Unparse
+import qualified Doc.Chars as UC
+import ANSI
+import Options
+import Char
+import GenUtil
+import Name
+import qualified Data.Map as Map
+import VConsts
+import Atom(intToAtom)
+import FreeVars
+import Atom(Atom,fromAtom,toAtom)
+import Doc.PPrint
+
+-----------------
+-- Pretty Print E
+-----------------
+
+
+instance PPrint Doc E where
+    pprint x = ePretty x
+
+    
+
+instance DocLike d => PPrint d TVr where
+    pprint TVr { tvrIdent = i }  = prettyI i
+
+{-
+fromHsName :: HsName -> String
+fromHsName (UnQual i) =  hsIdentString i
+fromHsName (Qual (Module "Prelude") i) =  hsIdentString i
+fromHsName (Qual (Module m) i) =  m ++ "." ++ hsIdentString i
+-}
+
+
+isTup ('(':',':xs) | (a,")") <- span (== ',') xs = return (length a + 2)
+isTup _ = fail "Not tuple"
+
+
+render :: Doc -> String
+render doc =  displayS (renderPretty 0.95 (optColumns options)  doc) ""
+
+data PrettyOpt = PrettyOpt { 
+    optExpanded :: Bool, 
+    optColors :: Bool, 
+    optNames :: Int -> Doc 
+    }
+
+prettyOpt = PrettyOpt { optExpanded = False, optColors = True, optNames = pName Map.empty }
+
+
+
+ePretty e = ePrettyN Map.empty e
+ePrettyEx e = (eDoc e prettyOpt { optExpanded = True}) 
+ePrettyN m e = (eDoc e prettyOpt { optNames = pName m}) 
+ePrettyNEx m e = (eDoc e prettyOpt { optExpanded = True, optNames = pName m}) 
+prettyE :: E -> String
+prettyE e = render $ ePrettyN Map.empty e
+prettyENameEx m e = render $ ePrettyNEx m e
+        
+{-
+pName nm = \i -> case IM.lookup i m of {Just d -> d ; Nothing -> text ('x':show i)} where 
+        m = IM.fromList [(i,text $  gn n) | (n,i) <- nm ]
+        gn (Left n) = fromHsName n --  $ fromAtom $ getName n
+        gn (Right n) = UC.uArrow ++ fromHsName n --  (fromAtom $ getName n)
+-}        
+
+pName m i = case Map.lookup i m of
+    Nothing -> text $ 'x':show i
+    Just n -> case nameType n of
+        TypeVal -> text $ UC.uArrow ++ show n 
+        _ -> text $ show n 
+
+
+
+
+prettyTvr t = ( (eDoc (EVar t)) prettyOpt)
+
+
+bold :: Doc -> Doc
+bold doc = oob attrBold <> doc <> oob attrClear
+
+color :: Int -> Doc -> Doc
+color 1 doc = oob (attr [1]) <> doc <> oob (attr [0])
+color c doc = oob (attr [c]) <> doc <> oob (attr [39])
+
+
+    
+instance Unparsable Doc where
+    unparseCat  =  (<>) 
+    unparseSpace  =  (<>) 
+    unparseGroup  = parens 
+
+prettyI 0 = (char '_')
+prettyI i | Just x <- intToAtom i  = (text $ show  $ (fromAtom x :: Name))
+prettyI i = (text $ 'x':show i)
+
+
+--(eDoc,tvrDoc) :: Monad m => E -> m Doc,Mona
+eDoc e PrettyOpt {optExpanded = expanded, optColors = colors, optNames = optNames} = unparse (prettye e) where
+    retOp x = col 92 x
+
+    bold' = if colors then bold else id
+    bc = bold' . char 
+    col n x = if colors then  (color n x) else x
+
+    keyword x = bold' (text x)
+    symbol x = atom (col 1 x)
+    
+    atomize (x,_) = (x,Atom)
+
+    prettylit :: (a -> Unparse Doc) -> Lit a E -> Unparse Doc
+    prettylit pbind (LitInt c t) | t == tChar = atom $ (col 94 (text (show $ chr $ fromIntegral  c)))
+    prettylit pbind (LitInt i _) = atom $ (col 94 (text $ show i)) 
+--    prettylit pbind (LitFrac f _) = atom $ (col 94 (text (show f)))
+    prettylit pbind (LitCons s es _) | Just n <- isTup (snd $ (snd $ fromName s :: (String,String))), n == length es = atom $ tupled (map (unparse . pbind) es) 
+    prettylit pbind (LitCons n [a,b] _) | vCons == n  = (pbind a) `cons` (pbind b)
+    prettylit pbind (LitCons n [e] _) | toName TypeConstructor ("Prelude","[]") == n = atom   (char '[' <> unparse (pbind e)  <> char ']')
+    prettylit pbind (LitCons s es _) | not expanded = foldl app  (atom $ text (snd $ fromName s)) ( map pbind es) 
+    prettylit pbind (LitCons s es t) = foldl app (atom (text (snd $ fromName s))) ( map pbind es) `inhabit` prettye t
+
+    inhabit = bop (N,-2) $ retOp UC.coloncolon
+    arr = bop (R,0) $ retOp (space <> UC.rArrow <> space)
+    dot = bop (R,-1) $ retOp (char '.')
+    app = bop (L,100) (text " ") 
+    cons = bop (R,5) (text ":")
+
+    prettytvr TVr { tvrIdent = i, tvrType =  t} = atom (prettyI i) `inhabit` prettye t
+
+    prettye me =  case me of
+        e | Just s <- toString e -> atom $ text $ show s
+        e | Just xs <- toList e -> atom $ list (map (unparse . prettye) xs) 
+        (EAp a b) -> (prettye a) `app` (prettye b)
+        (ELam (TVr {tvrIdent =  i, tvrType =  z}) e) | z == eStar ->  (pop (retOp UC.lAmbda) (atom $ prettyI i)) `dot` prettye e
+        (ELam t e) ->  (pop (retOp UC.lambda) (atomize $ prettytvr t)) `dot` prettye e
+        (EPi (TVr { tvrIdent = 0, tvrType =  e1}) e)  -> prettye e1 `arr` prettye e
+        (EPi (TVr { tvrIdent = j, tvrType =  e1}) e) | j `notElem` freeVars e -> prettye e1 `arr` prettye e
+        (EPi (TVr { tvrIdent = i, tvrType =  z}) e) | z == eStar ->  (pop (retOp UC.forall) (atom $ prettyI i)) `dot` prettye e
+        (EPi t e) ->  (pop (retOp UC.pI) (atomize $ prettytvr t)) `dot` prettye e
+        (EVar tvr) | expanded -> prettytvr tvr
+        (EVar (TVr { tvrIdent = i })) -> atom $ prettyI i
+        Unknown -> symbol (char  '?')
+        e | e == eStar -> symbol UC.star
+        e | e == eBox -> symbol UC.box
+        (ESort n) -> symbol $ text "Sort" <> tshow n
+        (ELit l) -> prettylit prettye l
+        (ELetRec bg e) -> rtup (Fix L (-10)) $ let
+            bg' = map ((<> bc ';') . unparse . prettydecl ) bg 
+            e' = unparse  (prettye e)
+            in group ( nest 4  ( keyword "let" </> (align $ sep bg') </> (keyword "in" <+> e')) )
+        ec@(ECase { eCaseScrutinee = e, eCaseAlts = alts }) -> rtup (Fix L (-10)) $ let
+            e' = unparse $ prettye e
+            alts' = map  ((<> bc ';') . prettyalt b) alts ++ dcase 
+            b = eCaseBind ec
+            dcase = maybe [] ( (:[]) . pdef b) (eCaseDefault ec)
+            in  group ( nest 4 ( keyword "case" <+> e' <+> keyword "of" <$>  (align $ sep (alts'))) )
+        (EPrim s es t) -> atom (angles  (unparse $ foldl app (atom (pprint s)) ( map prettye es) `inhabit` prettye t) )
+        (EError s t) -> atom $ angles ( UC.bottom <> char ':' <> text s <>  UC.coloncolon <> unparse (prettye t) )
+
+    prettyalt b (Alt l e) = nest 4 $ fill 10 ((unparse (prettylit prettytvr l)) <+>  UC.rArrow </> (unparse (prettye e)))
+    pdef b e =  unparse (prettytvr b) <+>  UC.rArrow <+> unparse (prettye e) <> bc ';'
+
+
+    prettydecl (t,e) =  atom $ nest 4 $ unparse (prettytvr t) <+> retOp (char '=') </> unparse (prettye e)
+
addfile ./E/PrimOpt.hs
hunk ./E/PrimOpt.hs 1
+module E.PrimOpt(primOpt,primOpt') where
+
+import E.E
+import Stats
+import E.TypeCheck
+import Atom
+import E.Values
+import List
+import C.Prims
+import Doc.PPrint
+import Doc.DocLike
+import DataConstructors
+import Data.Monoid
+import Monad
+import NameMonad
+import FreeVars
+import GenUtil
+
+
+-- Some of these arn't optimizations, but rather important transformations.
+
+primOpt dataTable stats e = do
+    runStatIO stats (primOpt' dataTable e)  
+
+create_integralCast dataTable e t = ECase e (tVr 0 te) [Alt (LitCons cna [tvra] te) cc] Nothing  where
+    te = typ e       
+    (vara:varb:_) = freeNames (freeVars (e,t))
+    tvra =  tVr vara sta
+    tvrb =  tVr varb stb
+    Just (cna,sta,ta) = lookupCType' dataTable te
+    Just (cnb,stb,tb) = lookupCType' dataTable t
+    cc = if ta == tb then ELit (LitCons cnb [EVar tvra] t) else
+        eStrictLet  tvrb (EPrim (APrim (CCast ta tb) mempty) [EVar tvra] stb)  (ELit (LitCons cnb [EVar tvrb] t))
+
+unbox :: DataTable -> E -> Int -> (TVr -> E) -> E 
+unbox dataTable e vn wtd = ECase e (tVr 0 te) [Alt (LitCons cna [tvra] te) (wtd tvra)] Nothing where 
+    te = typ e       
+    tvra = tVr vn sta 
+    Just (cna,sta,ta) = lookupCType' dataTable te
+
+intt = rawType "int"
+
+primOpt' dataTable  (EPrim (APrim s _) xs t) | Just n <- primopt s xs t = do
+    mtick (toAtom $ "E.PrimOpt." ++ braces (pprint s) )
+    primOpt' dataTable  n  where
+        primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
+        --primopt (PrimPrim "prim_op_aaB.==") [e,(ELit (LitInt x t)) ] rt = return $ eCase e [Alt (LitInt x t) (prim_unsafeCoerce vTrue rt)] (prim_unsafeCoerce vFalse rt)
+        --primopt (PrimPrim "prim_op_aaB.==") [(ELit (LitInt x t)),e ] rt = return $ eCase e [Alt (LitInt x t) (prim_unsafeCoerce vTrue rt)] (prim_unsafeCoerce vFalse rt)
+        primopt (Operator "==" [ta,tb] tr) [e,(ELit (LitInt x t))] rt = return $ eCase e [Alt (LitInt x t) (ELit (LitInt 1 intt)) ] (ELit (LitInt 0 intt))
+        primopt (Operator "==" [ta,tb] tr) [(ELit (LitInt x t)),e] rt = return $ eCase e [Alt (LitInt x t) (ELit (LitInt 1 intt)) ] (ELit (LitInt 0 intt))
+        primopt (Operator "-" [ta] tr) [ELit (LitInt x t)] rt | ta == tr && rt == t = return $ ELit (LitInt (negate x) t)
+
+        {-
+        primopt (PrimPrim "divide") [a,b] t = do
+            (_,ta) <- lookupCType dataTable (typ a)
+            (_,tb) <- lookupCType dataTable (typ b)
+            (_,tr) <- lookupCType dataTable t
+            unless (ta == tb && tb == tr) $ fail "bad divide"
+            return $ EPrim (APrim (Operator "/" [ta,tb] tr) mempty) [a,b] t
+        -}
+
+        primopt (PrimPrim "divide") [a,b] t = ans where
+            (vara:varb:varc:_) = freeNames (freeVars (a,b,t))
+            Just (cna,sta,ta) = lookupCType' dataTable t
+            ans = do
+                (_,ta) <- lookupCType dataTable (typ a)
+                (_,tb) <- lookupCType dataTable (typ b)
+                (_,tr) <- lookupCType dataTable t
+                unless (ta == tb && tb == tr) $ fail "bad divide"
+                return $ unbox dataTable a vara $ \tvra ->
+                    unbox dataTable b varb $ \tvrb -> 
+                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "/" [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (LitCons cna [EVar (tVr varc sta)] t)) 
+
+                --return $ EPrim (APrim (Operator "/" [ta,tb] tr) mempty) [a,b] t
+
+        --primopt (PrimPrim pn) [] t | Just c <-  getPrefix "const." pn = do
+        --    (_,ta) <- lookupCType dataTable t
+        --    return $ EPrim (APrim (CConst c ta) mempty) [] t
+        primopt (PrimPrim pn) [] t | Just c <-  getPrefix "const." pn = do
+            (cn,st,ct) <- case lookupCType' dataTable t of 
+                Right x -> return x
+                Left x -> error x
+            let (var:_) = freeNames (freeVars t)
+            return $ eStrictLet (tVr var st) (EPrim (APrim (CConst c ct) mempty) [] st) (ELit (LitCons cn [EVar $ tVr var st] t))
+            
+        
+        primopt (PrimPrim "integralCast") [e] t = return $ create_integralCast dataTable e t
+        --primopt (PrimPrim "integralCast") [e] t | Just (_,ta) <- lookupCType dataTable (typ e), Just (_,tb) <- lookupCType dataTable t =
+        --    if ta == tb then return (prim_unsafeCoerce e t)  else return $ EPrim (APrim (CCast ta tb) mempty) [e] t
+        primopt (PrimPrim "integralCast") es t = error $ "Invalid integralCast " ++ show (es,t)
+        primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t)  -- TODO ensure constant fits
+        --primopt (CCast x y) [e] t | x == y = return $ prim_unsafeCoerce e t
+        primopt _ _ _ = fail "No primitive optimization to apply"
+primOpt' _  x = return x
+
+
+
+--primopt "primEqInt" [ELit (LitInt x _),ELit (LitInt y _) ] _ = return $ if x == y then vTrue else vFalse
+--primopt "primEqChar" [ELit (LitInt x _),ELit (LitInt y _)] _ = return $ if x == y then vTrue else vFalse
+--primopt "primEq" [ELit (LitInt x _),ELit (LitInt y _) ] _ = return $ if x == y then vTrue else vFalse
+{-
+--primopt (PrimPrim "seq") [x,y] _ | isWHNF x  = return y
+primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
+primopt (PrimPrim "ord") [ELit (LitInt x t)] _ | t == tChar = return $ ELit (LitInt x tInt)
+primopt (PrimPrim "chr") [ELit (LitInt x t)] _ | t == tInt  = return $ ELit (LitInt x tChar)
+--primopt "prim_op.==" [e,(ELit (LitInt x t)) ] _ = return $ eCase e [Alt (LitInt x t) vTrue] vFalse
+--primopt "prim_op.==" [(ELit (LitInt x t)),e ] _ = return $ eCase e [Alt (LitInt x t) vTrue] vFalse
+--primopt "prim_op.!=" [e,(ELit (LitInt x t)) ] _ = return $ eCase e [Alt (LitInt x t) vFalse] vTrue
+--primopt "prim_op.!=" [(ELit (LitInt x t)),e ] _ = return $ eCase e [Alt (LitInt x t) vFalse] vTrue
+primopt (PrimPrim "unsafeCoerce") [e'] t | Just (x,_) <- from_unsafeCoerce e' = return $ prim_unsafeCoerce x t
+primopt (PrimPrim "unsafeCoerce") [EError err _] t  = return $ EError err t
+primopt (PrimPrim "unsafeCoerce") [ELit (LitInt x _)] t  = return $ ELit (LitInt x t)
+--primopt (PrimPrim "unsafeCoerce") [ELit (LitFrac x _)] t  = return $ ELit (LitFrac x t)
+primopt (PrimPrim "unsafeCoerce") [ELit (LitCons x y _)] t  = return $ ELit (LitCons x y t)
+primopt (PrimPrim "unsafeCoerce") [x] t | typ x == t = return x
+
+primopt (PrimPrim "integralCast") [e'] t | Just (x,_) <- from_integralCast e' = return $ prim_integralCast x t
+primopt (PrimPrim "integralCast") [EError err _] t  = return $ EError err t
+primopt (PrimPrim "integralCast") [ELit (LitInt x _)] t  = return $ ELit (LitInt x t)
+primopt (PrimPrim "integralCast") [ELit (LitCons x y _)] t  = return $ ELit (LitCons x y t)
+primopt (PrimPrim "integralCast") [x] t | typ x == t = return x
+primopt _ _ _ = fail "No primitive optimization to apply"
+
+--primopt "unsafeCoerce" [ELetRec ds e] t  = return $ ELetRec ds (EPrim "unsafeCoerce" [e] t)
+--primopt "unsafeCoerce" [ELetRec ds e] t  = return $ ELetRec ds (EPrim "unsafeCoerce" [e] t)
+
+primOpt dataTable  stats (EPrim (APrim s _) xs t) | Just n <- primopt s xs t = do
+    tick stats (toAtom $ "E.PrimOpt." ++ braces (pprint s) )
+    primOpt dataTable stats n  where
+        primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
+        primopt (PrimPrim "prim_op_aaB.==") [e,(ELit (LitInt x t)) ] rt = return $ eCase e [Alt (LitInt x t) (prim_unsafeCoerce vTrue rt)] (prim_unsafeCoerce vFalse rt)
+        primopt (PrimPrim "prim_op_aaB.==") [(ELit (LitInt x t)),e ] rt = return $ eCase e [Alt (LitInt x t) (prim_unsafeCoerce vTrue rt)] (prim_unsafeCoerce vFalse rt)
+        --primopt "prim_op.!=" [e,(ELit (LitInt x t)) ] _ = return $ eCase e [Alt (LitInt x t) vFalse] vTrue
+        --primopt "prim_op.!=" [(ELit (LitInt x t)),e ] _ = return $ eCase e [Alt (LitInt x t) vFalse] vTrue
+        primopt (PrimPrim "unsafeCoerce") [e'] t | Just (x,_) <- from_unsafeCoerce e' = return $ prim_unsafeCoerce x t
+        primopt (PrimPrim "unsafeCoerce") [EError err _] t  = return $ EError err t
+        primopt (PrimPrim "unsafeCoerce") [ELit (LitInt x _)] t  = return $ ELit (LitInt x t)
+        primopt (PrimPrim "unsafeCoerce") [ELit (LitCons x y _)] t  = return $ ELit (LitCons x y t)
+        primopt (PrimPrim "unsafeCoerce") [x] t | typ x == t = return x
+
+        primopt (PrimPrim "divide") [a,b] t = do
+            (_,ta) <- lookupCType dataTable (typ a)
+            (_,tb) <- lookupCType dataTable (typ b)
+            (_,tr) <- lookupCType dataTable t
+            unless (ta == tb && tb == tr) $ fail "bad divide"
+            return $ EPrim (APrim (Operator "/" [ta,tb] tr) mempty) [a,b] t
+
+        primopt (PrimPrim pn) [] t | Just c <-  getPrefix "const." pn = do
+            (_,ta) <- lookupCType dataTable t
+            return $ EPrim (APrim (CConst c ta) mempty) [] t
+            
+        
+        primopt (PrimPrim "integralCast") [e] t | Just (_,ta) <- lookupCType dataTable (typ e), Just (_,tb) <- lookupCType dataTable t =
+            if ta == tb then return (prim_unsafeCoerce e t)  else return $ EPrim (APrim (CCast ta tb) mempty) [e] t
+        primopt (PrimPrim "integralCast") es t = error $ "Invalid integralCast " ++ show (es,t)
+        primopt (CCast _ _) [ELit (LitInt x _)] t = return $ ELit (LitInt x t)  -- TODO ensure constant fits
+        primopt (CCast x y) [e] t | x == y = return $ prim_unsafeCoerce e t
+            
+        --primopt (PrimPrim "integralCast") [e'] t | Just (x,_) <- from_integralCast e' = return $ prim_integralCast x t
+        --primopt (PrimPrim "integralCast") [EError err _] t  = return $ EError err t
+        --primopt (PrimPrim "integralCast") [ELit (LitInt x _)] t  = return $ ELit (LitInt x t)
+        --primopt (PrimPrim "integralCast") [ELit (LitCons x y _)] t  = return $ ELit (LitCons x y t)
+        --primopt (PrimPrim "integralCast") [x] t | typ x == t = return x
+        primopt _ _ _ = fail "No primitive optimization to apply"
+primOpt _ _stats x = return x
+-}
addfile ./E/Rules.hs
hunk ./E/Rules.hs 1
+module E.Rules(
+    Rules, 
+    Rule(ruleHead,ruleBinds,ruleArgs,ruleBody,ruleName),
+    ruleFreeVars,
+    ruleAllFreeVars,
+    applyRule'',
+    ruleFreeVars',
+    fromRules,
+    emptyRule,
+    printRule,
+    printRules,
+    applyRule,
+    mapBodies,
+    applyRule'
+    )where
+
+import E.Eval
+import E.E
+import E.Values
+import Stats
+import qualified Data.Map as Map
+import Data.Monoid
+import Binary
+import E.Subst
+import qualified Data.IntMap as IM
+import GenUtil
+import MapBinaryInstance()
+import E.Pretty
+import Atom(toAtom,fromAtom,Atom)
+import Name
+import FreeVars
+import qualified Data.Set as Set
+import HasSize
+
+
+
+
+data Rule = Rule {
+    ruleHead :: TVr,
+--    ruleFvs :: Set.Set Int,
+    ruleBinds :: [TVr],
+    ruleArgs :: [E],
+    ruleBody :: E,
+    ruleName :: Atom
+    }
+ {-! derive: GhcBinary !-}
+
+
+emptyRule :: Rule
+emptyRule = Rule { 
+    ruleHead = error "ruleHead undefined", 
+--    ruleFvs = error "ruleFvs undefined",
+    ruleArgs = [],
+    ruleBinds = [],
+    ruleBody = error "ruleBody undefined",
+    ruleName = error "ruleName undefined"
+    }
+
+newtype Rules = Rules (Map.Map TVr [Rule]) 
+    deriving(HasSize,Binary)
+
+mapBodies :: (E ->  E) -> Rules ->  Rules 
+mapBodies g (Rules mp) = Rules $ Map.map (map f) mp where
+    f rule = rule { ruleBody = g (ruleBody rule) }
+    --    return rule { ruleBody = b }
+
+
+ruleAllFreeVars (Rules r) = freeVars (concatMap (map ruleBody) (Map.elems r)) 
+
+ruleFreeVars ::  Rules -> TVr -> Set.Set Int
+ruleFreeVars (Rules r) tvr = case Map.lookup tvr r of
+    Nothing -> mempty
+    --Just rs -> mconcat (map ruleFvs rs) -- (freeVars (map ruleBody rs) Set.\\ freeVars (map ruleArgs rs)) 
+    Just rs -> (freeVars (map ruleBody rs) Set.\\ freeVars (map ruleArgs rs)) 
+ruleFreeVars' ::  Rules -> Int -> Set.Set Int
+ruleFreeVars' (Rules r) tvr = case Map.lookup (tVr tvr undefined) r of
+    Nothing -> mempty
+    --Just rs -> mconcat (map ruleFvs rs) -- (freeVars (map ruleBody rs) Set.\\ freeVars (map ruleArgs rs)) 
+    Just rs -> (freeVars (map ruleBody rs) Set.\\ freeVars (map ruleArgs rs)) 
+
+printRule rule = do
+    putErrLn $ fromAtom (ruleName rule)  
+    putErr $ "    " ++ render (ePretty (foldl EAp (EVar $ ruleHead rule) (ruleArgs rule))) 
+    putErrLn $ " -> " ++ render (ePretty (ruleBody rule))
+
+printRules (Rules rules) = mapM_ printRule (concat $ Map.elems rules)
+
+combineRules as bs = map head $ sortGroupUnder ruleName (as ++ bs)
+
+instance Monoid Rules where 
+    mempty = Rules mempty
+    mappend (Rules x) (Rules y) = Rules $ Map.unionWith (combineRules) x y
+
+
+fromRules :: [Rule] -> Rules
+fromRules rs = Rules $ Map.map snds $ Map.fromList $ sortGroupUnderF fst [ (ruleHead r,f r) | r <- rs ] where
+    f rule = rule
+    --f rule = rule { ruleFvs = fvs rule } where
+    --fvs rule = (freeVars $ ruleBody rule) Set.\\ freeVars (ruleArgs rule) 
+
+
+applyRule stats rules (EVar tvr) xs = do
+    z <- applyRule' stats rules tvr xs 
+    case z of
+        Just (x,xs) -> return $ foldl EAp x xs
+        Nothing -> return $ foldl EAp (EVar tvr) xs
+applyRule _stats _rules _ _xs = fail "Can't apply rule"
+
+preludeError = nameValue "Prelude" "error"
+ruleError = toAtom "Rule.error/EError"
+
+applyRule' stats _ (TVr { tvrIdent = n }) (ty:s:rs) | n == preludeError, Just s' <- toString s  = do
+        tick stats ruleError
+        return $ Just ((EError ("Prelude.error: " ++ s') ty),rs)  
+applyRule' stats (Rules rules) tvr xs = ans where
+    ans = case Map.lookup tvr rules of
+            Just rs -> f rs
+            _ -> return Nothing
+    f [] = return Nothing
+    f (r:_) | nArgs <= length xs, Just ss <- sequence (zipWith unify (ruleArgs r) xs) = ans ss where
+        nArgs = length (ruleArgs r)
+        ans ss = do
+            tick stats (ruleName r)
+            let b = substMap (IM.fromList [ (i,x) | ~(~(EVar (TVr { tvrIdent = i })),x) <- concat ss ]) (ruleBody r)
+            return $ Just (b,(drop nArgs xs)) 
+    f (_:rs) = f rs 
+        
+applyRule'' _ (TVr { tvrIdent = n }) (ty:s:rs) | n == preludeError, Just s' <- toString s  = do
+        mtick ruleError
+        return $ Just ((EError ("Prelude.error: " ++ s') ty),rs)  
+applyRule'' (Rules rules) tvr xs = ans where
+    ans = case Map.lookup tvr rules of
+            Just rs -> f rs
+            _ -> return Nothing
+    f [] = return Nothing
+    f (r:_) | nArgs <= length xs, Just ss <- sequence (zipWith unify (ruleArgs r) xs) = ans ss where
+        nArgs = length (ruleArgs r)
+        ans ss = do
+            mtick (ruleName r)
+            let b = substMap (IM.fromList [ (i,x) | ~(~(EVar (TVr { tvrIdent = i })),x) <- concat ss ]) (ruleBody r)
+            return $ Just (b,(drop nArgs xs)) 
+    f (_:rs) = f rs 
+
+
+
addfile ./E/SSimplify.hs
hunk ./E/SSimplify.hs 1
+module E.SSimplify(Occurance(..), simplify, SimplifyOpts(..), app) where
+
+import Atom
+import Control.Monad.Identity
+import Control.Monad.Writer
+import DataConstructors
+import Data.FunctorM
+import Data.Monoid
+import E.E
+import E.PrimOpt
+import E.Rules
+import E.Subst
+import E.Values
+import qualified Info
+import qualified E.Strictness as Strict
+import FreeVars
+import GenUtil
+import GraphUtil
+import List
+import Name
+import NameMonad
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified E.Strictness as Strict
+import qualified Seq
+import Stats hiding(new,print,Stats)
+import CanType
+import Data.Generics
+import VConsts
+
+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
+    deriving(Show,Eq,Ord)
+
+
+
+combineOccInfo k a b | a == b = a
+combineOccInfo k a b =  error $ "Conflicting occurance info: " ++ show (k,a,b)
+
+data StrictInfo = NoStrict | Strict  
+    deriving(Typeable)
+
+-- | This collects occurance info for variables, deletes dead expressions, and reorders let-bound variables in dependency order.
+collectOcc :: SimplifyOpts ->  E -> (E,Set.Set Int,Map.Map TVr Occurance)
+collectOcc sopts  e = (e',fvs,occ) where  
+    topLevels = so_exports sopts
+    rules  = so_rules sopts
+    dataTable = so_dataTable sopts
+    ((e',fvs,_),occ') = runWriter $ f e
+    rule_set = ruleAllFreeVars rules
+    occ = foldl (Map.unionWithKey combineOccInfo) mempty (Seq.toList occ')  
+    f e@(EPi (TVr { tvrIdent = 0, tvrType =  a}) b) = return (e,(freeVars [a,b]),(args [a,b]))
+    f e@(EPi tvr@(TVr { tvrIdent = n, tvrType =  a}) b) = if n `Set.member` fvs || n `Map.member` ags then return (e,Set.delete n fvs ,Map.delete n ags) else return (EPi (tvr { tvrIdent =  0 } ) b,fvs,ags)  where
+        fvs = (freeVars [a,b])
+        ags = args [a,b]
+    f e@(ELit (LitCons n as t)) = return (e,freeVars (t:as),args as)
+    f e@ELit {} = return (e,freeVars e,mempty)
+    f e@(EPrim _ as t) = return (e,freeVars (t:as),args as)
+    f e@(EError _ t) =  return (e,freeVars t,mempty)
+    f e@ELam {} | (b,as) <- fromLam e = do
+        (b',fvs,bs) <- f b 
+        return (foldr ELam b' as,foldr Set.delete  (freeVars (map tvrType as) `mappend` fvs) (map tvrNum as), Map.map inLam $ foldr Map.delete bs (map tvrNum as))
+    f e | Just (x,t) <- from_unsafeCoerce e  = do (a,b,c) <- f x ; return (prim_unsafeCoerce a t, b `mappend` freeVars t, c)
+    f e | (EVar (TVr { tvrIdent = n, tvrType =  t}),xs) <- fromAp e = do
+        return (e,freeVars (t:xs), Map.singleton n Once `andOM` args xs) 
+    f ec@(ECase e b as d) = do
+        (e',fva,sa) <- f e
+        (d',fvb,sb) <- case d of 
+            Nothing -> return (Nothing,mempty,mempty)
+            Just e -> do (a,b,c) <- f e; return (Just a,b,c)
+        (as',fvas,ass) <- mapAndUnzip3M alt as
+        let fvs = mconcat $ [fva,freeVars $ tvrType b, fvb] ++ fvas
+        return (ECase e' b as' d', fvs, sa `andOM` orMaps (sb:ass) )
+    f (ELetRec ds e) = do
+        ds' <- mapM  (censor (const mempty) . listen . f . snd) ds
+        let gfv (_,fv,i) = fvs ++ Set.toList (mconcat (map (ruleFreeVars' rules) (fvs)))  where
+                fvs = Set.toList (Set.fromAscList (Map.keys i) `Set.union` fv)
+        let gr = newGraph (zip (fsts ds) ds') (tvrNum . fst) (gfv . fst . snd )
+        (e',fve,se) <- f e
+        let nn' = reachable gr (Set.toList fve ++ Map.keys se ++  topLevels)
+        nn <- sequence [ tell t >> return (x,y) |  (x,(y,t)) <- nn' ]
+        let gr' = newGraph nn (tvrNum . fst) (gfv . snd )
+            (lb,ds'') = findLoopBreakers (\ (_,(e,_,_)) -> loopFunc e) gr' 
+            cycNodes = Set.fromList $ [ v | (v,_) <- cyclicNodes gr'] 
+            calcStrictInfo t e 
+                | t `Set.member` cycNodes = NoStrict
+                | Just (Strict.S _) <- Map.lookup (tvrNum t) (so_strictness sopts) = Strict
+                | otherwise = NoStrict
+        let dvars = map (tvrNum . fst) ds 
+            fvs = foldr Set.delete (mconcat (fve:[ fv `mappend` freeVars t | (TVr { tvrType =  t},(_,fv,_)) <- ds'' ])) dvars
+            finalS = Map.union (Map.fromList [(n,LoopBreaker) | (TVr { tvrIdent = n },_) <- lb ]) $   foldl andOM se ([ s | (_,(_,_,s)) <- ds'' ])
+        tell $ Seq.singleton (Map.fromList [ (t,Map.findWithDefault Unused n (Map.mapWithKey frules finalS)) | (t@(TVr { tvrIdent = n }),_) <- ds'' ])
+        return (eLetRec [ (tvrInfo_u (Info.insert (calcStrictInfo v e)) v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
+    f e@(EAp a b)  = case runIdentity $ app (fromAp e) of 
+            EAp a' b' | a == a' && b == b' -> error $ "SSimplify.collectOcc.f: " ++ show e
+            e -> f e
+    f e = error $ "SSimplify.collectOcc.f: " ++ show e
+    frules k _ | k `Set.member` rule_set = Many
+    frules _ x = x
+    alt (Alt l e) = do
+        (e',b,c) <- f e
+        return (Alt l e',foldr Set.delete (freeVars l `mappend` b) (map tvrNum $ litBinds l),foldr Map.delete c (map tvrNum $ litBinds l))
+    args as = ans where
+        ans = Map.fromList [ (i,Many) | Just (EVar (TVr { tvrIdent = i }),_) <- map (\e -> from_unsafeCoerce e `mplus` Just (e,Unknown)) as]
+        {-
+    f (ELetRec ds e) = do
+        ds' <- mapM  (f . snd) ds
+        let gfv (_,fv,i) = fvs ++ Set.toList (mconcat (map (ruleFreeVars' rules) (fvs)))  where
+                fvs = Set.toList (Set.fromAscList (Map.keys i) `Set.union` fv)
+        let gr = newGraph (zip (fsts ds) ds') (tvrNum . fst) (gfv . snd)
+        (e',fve,se) <- f e
+        let nn = reachable gr (Set.toList fve ++ Map.keys se ++  topLevels)
+        let gr' = newGraph nn (tvrNum . fst) (gfv . snd)
+            (lb,ds'') = findLoopBreakers (\ (_,(e,_,_)) -> loopFunc e) gr' 
+        let dvars = map (tvrNum . fst) ds 
+            fvs = foldr Set.delete (mconcat (fve:[ fv `mappend` freeVars t | (TVr _ t,(_,fv,_)) <- ds'' ])) dvars
+            finalS = Map.union (Map.fromList [(n,LoopBreaker) | (TVr n _,_) <- lb ]) $   foldl andOM se ([ s | (_,(_,_,s)) <- ds'' ])
+        tell $ Seq.singleton (Map.fromList [ (t,Map.findWithDefault Unused n (Map.mapWithKey frules finalS)) | (t@(TVr n _),_) <- ds'' ])
+        return (eLetRec [ (v,e) | (v,(e,_,_)) <- ds'' ] e', fvs, finalS  )
+        -}
+
+-- this should use the occurance info
+loopFunc EVar {} = 0 
+loopFunc ELit {} = 1
+loopFunc EPi {} = 1
+loopFunc EPrim {} = 2
+loopFunc EError {} = 2
+loopFunc ELam {} = 3 
+loopFunc _ = 4
+        
+mapAndUnzip3M     :: (Monad m) => (a -> m (b,c,d)) -> [a] -> m ([b], [c], [d])
+mapAndUnzip3M f xs = sequence (map f xs) >>= return . unzip3
+
+inLam Once = OnceInLam
+inLam _ = Many
+
+andOM x y = Map.unionWith andOcc x y
+andOcc _ _ = Many
+
+orMaps ms = Map.map orMany $ foldl (Map.unionWith (++)) mempty (map (Map.map (:[])) ms)
+
+orMany [] = error "empty orMany"
+orMany [x] = x
+orMany xs = if all (== Once) xs then ManyBranch else Many
+
+
+
+data SimplifyOpts = SimpOpts {
+    so_boundVars :: Map.Map Int E, 
+    so_properties :: Map.Map Name [Atom],
+    so_rules :: Rules,
+    so_dataTable :: DataTable,
+    so_strictness :: Map.Map Int Strict.SA,
+    so_exports :: [Int]
+    }
+    {-! derive: Monoid !-}
+
+
+data Range = Done E | Susp E Subst
+    deriving(Show)
+type Subst = Map.Map Int Range
+
+type InScope = Map.Map Int Binding 
+data Binding = NotAmong [Name] | IsBoundTo Occurance E | NotKnown
+
+data Env = Env {
+    envInScope :: Map.Map Int Binding,
+    envTypeMap :: Map.Map Int E
+    }
+    {-! derive: Monoid, update !-}
+
+applySubst :: Subst -> E -> E
+applySubst s = substMap'' (f s) where
+    f s = Map.fromAscList [ (x,g y) | (x,y) <- Map.toAscList s ]
+    g (Done e) = e
+    g (Susp e s') = applySubst s' e
+
+dosub sub e = do
+    coerceOpt return $ applySubst sub e
+--dosub sub e = coerceOpt (return . applySubst sub) e
+--coerceOpt f e = f e
+
+simplify :: SimplifyOpts -> E -> (E,Stat, Map.Map TVr Occurance)
+simplify sopts e = (e'',stat,occ) where 
+    exports = Set.fromList (so_exports sopts)
+    --(e',fvs,occ) = collectOcc (Set.toList exports) (so_rules sopts) (so_dataTable sopts)  e 
+    (e',fvs,occ) = collectOcc sopts  e 
+    addN = do
+        addNames (map tvrNum $ Map.keys occ)
+        addNames (Set.toList fvs)
+    initialB = mempty { envInScope = Map.fromAscList [ (i,IsBoundTo Many e)  | (i,e) <- Map.toAscList $ so_boundVars sopts] } 
+    (e'',stat)  = runIdentity $ runStatT (runNameMT (addN >> f e' mempty initialB)) -- (e,mempty)
+    go e inb = do
+        let (e',_,_) = collectOcc sopts  e 
+        f e' mempty inb
+    go :: E -> Env -> NameMT Int (StatT Identity) E
+    f :: E -> Subst -> Env -> NameMT Int (StatT Identity) E
+    f e sub inb | (EVar v,xs) <- fromAp e = do
+        xs' <- mapM (dosub sub) xs
+        case Map.lookup (tvrNum v) sub of 
+            Just (Done e) -> h e xs' inb   -- e is var or trivial
+            Just (Susp e s) -> do
+                e' <- f e s inb
+                h e' xs' inb
+                --app (e',xs')
+            Nothing -> h (EVar v) xs' inb
+            -- Nothing -> error $ "Var with no subst: " ++ show e ++ "\n" ++  show  sub -- h (EVar v) xs' inb    
+    f e sub inb | (x,xs) <- fromAp e = do
+        xs' <- mapM (dosub sub) xs
+        x' <- g x sub inb
+        x'' <- coerceOpt return x' 
+        x <- primOpt' (so_dataTable sopts) x''
+        --x' <- coerceOpt (\x -> g x sub inb) x
+        h x xs' inb 
+        --app (x,xs')
+    g (EPrim a es t) sub inb = do
+        es' <- mapM (dosub sub) es 
+        t' <- dosub sub t
+        return $ EPrim a es' t'
+    g (ELit (LitCons n es t)) sub inb = do
+        es' <- mapM (dosub sub) es 
+        t' <- dosub sub t
+        return $ ELit (LitCons n es' t')
+    g (ELit (LitInt n t)) sub inb = do
+        t' <- dosub sub t
+        return $ ELit (LitInt n t')
+    g e@(EPi (TVr { tvrIdent = n }) b) sub inb = do
+        addNames [n]
+        e' <- dosub sub e
+        return e'
+    g (EError s t) sub inb = do
+        t' <- dosub sub t
+        return $ EError s t'
+    --g (EVar v) sub inb = do 
+    --    case Map.lookup (tvrNum v) sub of 
+   --         Just (Done e) -> return e
+    --        Just (Susp e s) -> do
+    --            e' <- f e s inb
+    --            return e'
+            --Nothing -> return (EVar v)
+    --        Nothing -> error $ "vvar with no subst: " ++ show (EVar v) -- h (EVar v) xs' inb    
+    g ec@(ECase e b as d) sub inb = do
+        addNames (map tvrNum $ caseBinds ec)
+        e' <- f e sub inb 
+        doCase e' b as d sub inb
+    g (ELam v e) sub inb  = do
+        addNames [tvrNum v]
+        v' <- nname v sub inb 
+        e' <- f e (Map.insert (tvrNum v) (Done $ EVar v') sub) (envInScope_u (Map.insert (tvrNum v') NotKnown) inb) 
+        return $ ELam v' e'
+    g (ELetRec [] e) sub inb = g e sub inb
+    g (ELetRec ds e) sub inb = do
+        addNames $ map (tvrNum . fst) ds
+        -- let z (t,e) | worthStricting e && Just (S _) <- Map.lookup (tvrNum t) (so_strictness sopts)= do
+        let z (t,e) = do
+                t' <- nname t sub inb
+                case Map.lookup t occ of
+                    Just Once -> return (tvrNum t,Once,error $ "Once: " ++ show t,e)   
+                    Just n -> return (tvrNum t,n,t',e)   
+                    Nothing -> return (tvrNum t,Many,t',e)
+                    -- Nothing -> error $ "No Occurance info for " ++ show t 
+            w ((t,Once,t',e):rs) sub inb ds = do
+                mtick $ "E.Simplify.inline.Once.{" ++ tvrShowName (tVr t Unknown) ++ "}"
+                w rs (Map.insert t (Susp e sub) sub) inb ds
+            w ((t,n,t',e):rs) sub inb ds = do
+                e' <- f e sub inb
+                case isAtomic e' && n /= LoopBreaker of
+                    True -> do
+                        when (n /= Unused) $ mtick $ "E.Simplify.inline.Atomic.{" ++ tvrShowName (tVr t Unknown) ++ "}"
+                        w rs (Map.insert t (Done e') sub) (envInScope_u (Map.insert (tvrNum t') (IsBoundTo n e')) inb) ((t',e'):ds) 
+                    -- False | worthStricting e', Strict <- Info.lookup (tvrInfo t') -> w rs sub 
+                    False -> w rs sub (if n /= LoopBreaker then (envInScope_u (Map.insert (tvrNum t') (IsBoundTo n e')) inb) else inb) ((t',e'):ds) 
+            w [] sub inb ds = return (ds,sub,inb)
+        s' <- mapM z ds 
+        let 
+            sub'' = {- Map.fromList [ (t,Susp e sub'') | (t,Once,_,e) <- s'] `Map.union`-} (Map.fromList [ (t,Done (EVar t'))  | (t,n,t',_) <- s', n /= Once]) `Map.union` sub
+        (ds',sub',inb') <- w s' sub'' (envInScope_u (Map.fromList [ (tvrNum t',NotKnown) | (_,n,t',_) <- s', n /= Once] `Map.union`) inb) []
+        e' <- f e sub' inb' 
+        case ds' of
+            [(t,e)] | worthStricting e, Just Strict <- Info.lookup (tvrInfo t) -> do
+                mtick "E.Simplify.let-to-case" 
+                return $ eStrictLet t e e'
+            _ -> do
+                let fn ds (ELetRec ds' e) | not (hasRepeatUnder fst (ds ++ ds')) = fn (ds' ++ ds) e  
+                    fn ds e = f ds (Set.fromList $ fsts ds) [] False where
+                        f ((t,ELetRec ds' 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 (hasRepeatUnder fst ds'') $ fail "hasRepeats!"
+                mticks  (length ds'' - length ds') (toAtom $ "E.Simplify.let-coalesce")
+                return $ eLetRec ds'' e''
+                {-
+                let z (v,ELetRec ds e) = (ds,(v,e))
+                    z (v,e) = ([],(v,e))
+                    (ds''',ds'') = unzip (map z ds') 
+                    nds = (concat ds''' ++ ds'')
+                --mticks (length (concat ds''')) (toAtom $ "E.Simplify.let-coalesce.{" ++ unwords (sort (map tvrShowName $ map fst (concat ds'''))) ++ "}")
+                
+                if hasRepeatUnder fst nds then
+                    return $ eLetRec ds' e'
+                  else do
+                    mticks (length (concat ds''')) (toAtom $ "E.Simplify.let-coalesce")
+                    return $ eLetRec nds  e'
+                  -}
+    g e _ _ = error $ "SSimplify.simplify.g: " ++ show e
+
+    nname tvr@(TVr { tvrIdent = n, tvrType =  t}) sub inb  = do 
+        t' <- dosub sub t 
+        n' <- uniqueName n 
+        return $ tvr { tvrIdent = n', tvrType =  t' }
+--        case n `Map.member` inb of
+--            True -> do
+--                n' <- newName 
+--                return $ TVr n' t'
+--            False -> do
+--                n' <- uniqueName n 
+--                return $ TVr n' t'
+        
+    -- TODO - case simplification
+
+    doCase (ELetRec ds e) b as d sub inb = do
+        mtick "E.Simplify.let-from-case"
+        e' <- doCase e b as d sub inb
+        return $ ELetRec ds e'
+        
+    doCase (EVar v) b as d sub inb |  Just (IsBoundTo _ (ELit l)) <- Map.lookup (tvrNum v) (envInScope inb)  = doConstCase l b as d sub inb
+    doCase (ELit l) b as d sub inb  = doConstCase l b as d sub inb
+
+    doCase (EVar v) b as d sub inb | Just (IsBoundTo _ e) <- Map.lookup (tvrNum v) (envInScope inb) , isBottom e = do
+        mtick "E.Simplify.case-of-bottom'"
+        let t = typ (ECase (EVar v) b as d)
+        t' <- dosub sub t 
+        return $ prim_unsafeCoerce (EVar v) t' 
+
+    doCase ic@(ECase e b as d) b' as' d' sub inb | length (filter (not . isBottom) (caseBodies ic)) <= 1 || all whnfOrBot (caseBodies ic)  || all whnfOrBot (caseBodies (ECase Unknown b' as' d'))  = do
+        mtick (toAtom "E.Simplify.case-of-case") 
+        let f (Alt l e) = do
+                e' <- doCase e b' as' d' sub (envInScope_u (Map.fromList [ (n,NotKnown) | TVr { tvrIdent = n } <- litBinds l ] `Map.union`) inb) 
+                return (Alt l e')
+            --g e >>= return . Alt l 
+            g x = doCase x b' as' d' sub (envInScope_u (Map.insert (tvrNum b) NotKnown) inb) 
+        as'' <- mapM f as 
+        d'' <- fmapM g d
+        return (ECase e b as'' d'')      -- we duplicate code so continue for next renaming pass before going further.
+    doCase e b as d sub inb | isBottom e = do
+        mtick "E.Simplify.case-of-bottom"
+        let t = typ (ECase e b as d)
+        t' <- dosub sub t 
+        return $ prim_unsafeCoerce e t' 
+
+    doCase e b as@(Alt (LitCons n _ _) _:_) (Just d) sub inb | Just ss <- getSiblings (so_dataTable sopts) n, length ss <= length as = do
+        mtick "E.Simplify.case-no-default"
+        doCase e b as Nothing sub inb
+    doCase e b as (Just d) sub inb | te /= tWorld__, (ELit (LitCons cn _ _)) <- followAliases dt te, Just Constructor { conChildren = Just cs } <- getConstructor cn dt, length as == length cs - 1 || (False && length as < length cs && isAtomic d)  = do
+        let ns = [ n | Alt ~(LitCons n _ _) _ <- as ]
+            ls = filter (`notElem` ns) cs
+            f n = do
+                con <- getConstructor n dt 
+                let g t = do
+                        n <- newName
+                        return $ tVr n t
+                ts <- mapM g (slotTypes (so_dataTable sopts) n te) 
+                let wtd = ELit $ LitCons n (map EVar ts) te
+                return $ Alt (LitCons n ts te) (eLet b wtd d) 
+        mtick $ "E.Simplify.case-improve-default.{" ++ show (sort ls) ++ "}"
+        ls' <- mapM f ls
+        doCase e b (as ++ ls') Nothing sub inb
+        where
+        te = typ e
+        dt = (so_dataTable sopts)
+    doCase e b [] (Just d) sub inb | not (isLifted e) = do
+        mtick "E.Simplify.case-unlifted"
+        b' <- nname b sub inb
+        d' <- f d (Map.insert (tvrNum b) (Done (EVar b')) sub) (envInScope_u  (Map.insert (tvrNum b') (IsBoundTo Many e)) inb)  
+        return $ eLet b' e d' 
+    doCase (EVar v) b [] (Just d) sub inb | Just (NotAmong _) <-  Map.lookup (tvrNum v) (envInScope inb)  = do
+        mtick "E.Simplify.case-evaled"
+        d' <- f d (Map.insert (tvrNum b) (Done (EVar v)) sub) inb
+        return d'
+    doCase e b as d sub inb = do
+        b' <- nname b sub inb
+        let dd e' = f e' (Map.insert (tvrNum b) (Done $ EVar b') sub) (envInScope_u (newinb `Map.union`) inb) where
+                na = NotAmong [ n | Alt (LitCons n _ _) _ <- as]
+                newinb = Map.fromList [ (n,na) | EVar (TVr { tvrIdent = n }) <- [e,EVar b']] 
+            da (Alt (LitInt n t) ae) = do
+                t' <- dosub sub t 
+                let p' = LitInt n t'
+                e' <- f ae sub (mins e (patToLitEE p') inb)
+                return $ Alt p' e'
+            da (Alt (LitCons n ns t) ae) = do
+                t' <- dosub sub t 
+                ns' <- mapM (\v -> nname v sub inb) ns
+                let p' = LitCons n ns' t'
+                    nsub = Map.fromList [ (n,Done (EVar t))  | TVr { tvrIdent = n } <- ns | t <- ns' ]
+                    ninb = Map.fromList [ (n,NotKnown)  | TVr { tvrIdent = n } <- ns' ]
+                e' <- f ae (nsub `Map.union` sub) (envInScope_u (ninb `Map.union`) $ mins e (patToLitEE p') inb)
+                return $ Alt p' e'
+            mins (EVar v) e = envInScope_u (Map.insert (tvrNum v) (IsBoundTo Many $  e))
+            mins _ _ = id
+
+        d' <- fmapM dd d 
+        as' <- mapM da as 
+        return $ ECase e b' as' d'
+
+    doConstCase l b as d sub inb = do
+        (bs,e) <- match l as (b,d)      
+        let bs' = [ x | x@(TVr { tvrIdent = n },_) <- bs, n /= 0]
+        binds <- mapM (\ (v,e) -> nname v sub inb >>= return . (,,) e v) bs'
+        e' <- f e (Map.fromList [ (n,Done $ EVar nt) | (_,TVr { tvrIdent = n },nt) <- binds] `Map.union` sub)   (envInScope_u (Map.fromList [ (n,IsBoundTo Many e) | (e,_,TVr { tvrIdent = n }) <- binds] `Map.union`) inb) 
+        return $ eLetRec [ (v,e) | (e,_,v) <- binds ] e'
+        
+    match m@(LitCons c xs _) ((Alt (LitCons c' bs _) e):rs) d | c == c' = do
+        mtick (toAtom $ "E.Simplify.known-case." ++ show c ) 
+        return ((zip bs xs),e)
+         | otherwise = match m rs d
+    match m@(LitInt a _) ((Alt (LitInt b _) e):rs) d | a == b = do
+        mtick (toAtom $ "E.Simplify.known-case." ++ show a) 
+        return ([],e)
+         | otherwise = match m rs d
+    match l [] (b,Just e) = do 
+        mtick (toAtom "E.Simplify.known-case._") 
+        return ([(b,ELit l)],e)
+    match m [] (_,Nothing) = error $ "End of match: " ++ show m 
+    match m as d = error $ "Odd Match: " ++ show ((m,getType m),as,d)
+        
+    forceInline x | Just n <- tvrName x, Just xs <- Map.lookup n (so_properties sopts)  = toAtom "INLINE" `elem` xs
+    forceInline _ = False
+        
+
+
+    h (EVar v) xs' inb = do
+        z <- applyRule'' (so_rules sopts) v xs' 
+        case z of 
+            Just (x,xs) -> h x xs inb
+            Nothing -> case Map.lookup (tvrNum v) (envInScope inb) of
+                Just (IsBoundTo LoopBreaker _) -> app (EVar v,xs')
+                Just (IsBoundTo Once _) -> error "IsBoundTo: Once"
+                Just (IsBoundTo n e) | forceInline v -> do
+                    mtick  (toAtom $ "E.Simplify.inline.forced.{" ++ tvrShowName v  ++ "}")
+                    didInline inb (e,xs')
+                Just (IsBoundTo OnceInLam e) | safeToDup e && someBenefit e xs' -> do
+                    mtick  (toAtom $ "E.Simplify.inline.OnceInLam.{" ++ tvrShowName v  ++ "}")
+                    didInline inb (e,xs') 
+                Just (IsBoundTo ManyBranch e) | multiInline e xs' -> do
+                    mtick  (toAtom $ "E.Simplify.inline.ManyBranch.{" ++ tvrShowName v  ++ "}")
+                    didInline inb (e,xs') 
+                Just (IsBoundTo Many e) | safeToDup e && multiInline e xs' -> do
+                    mtick  (toAtom $ "E.Simplify.inline.Many.{" ++ tvrShowName v  ++ "}")
+                    didInline inb (e,xs') 
+                Just _ -> app (EVar v,xs')
+                Nothing  -> app (EVar v,xs')
+                -- Nothing | tvrNum v `Set.member` exports -> app (EVar v,xs')
+                -- Nothing -> error $ "Var not in scope: " ++ show v
+    h e xs' inb = do
+        app (e,xs') 
+    didInline inb z = do
+        e <- app z
+        go e inb
+        
+        
+
+someBenefit _ _ = True
+multiInline e xs = length xs + 2 >= nsize   where
+    (b,as) = fromLam e 
+    nsize = size b + abs (length as - length xs) 
+    size e | (x,xs) <- fromAp e = size' x + length xs
+    size' (EVar _) = 1
+    size' (ELit _) = 1
+    size' (EPi _ _) = 1
+    size' (ESort _) = 1
+    size' (EPrim _ _ _) = 1
+    size' (EError _ _) = 1
+    size' _ = 100
+    
+
+worthStricting x = isLifted x && not (isELit 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"
+
+{-
+    simp (p@EPrim {},xs) = do
+        p' <- primOpt dataTable stats p 
+        cont (p',xs)
+    f (ec@(ECase e _ _ _),[]) | isBottom e = do
+        tick stats (toAtom "E.Simplify.case-of-bottom") 
+        f (prim_unsafeCoerce e (typ ec),[])
+    f (ECase e b as (Just (ECase e' b' as' d')),[]) | e == e' = do 
+        tick stats (toAtom "E.Simplify.case-merging") 
+        let (nb,mdc)   
+                | tvrNum b == 0 = (b',id)
+                | tvrNum b' == 0 = (b,id)
+                | otherwise = (b,ELetRec [(b',EVar b)]) -- error "case-default-case: double bind"
+            nas' = filter ( (`notElem` map altHead as) . altHead) as' 
+        f (ECase e nb (as ++ nas') (fmap mdc d'),[])
+    f (oc@(ECase ic@(ECase e b as d) b' as' d'),[]) | length (filter (not . isBottom) (caseBodies ic)) <= 1 || all whnfOrBot (caseBodies ic) || all whnfOrBot (caseBodies oc) = do
+        tick stats (toAtom "E.Simplify.case-of-case") 
+        let f (Alt l e) = Alt l (g e)
+            g x = ECase x b' as' d'
+        cont (ECase e b (map f as) (fmap g d),[])      -- we duplicate code so continue for next renaming pass before going further.
+        
+    f ec@(ECase e b as@(Alt (LitCons n _ _) _:_) (Just d),[]) | Just ss <- getSiblings dataTable n, length ss <= length as = do
+        when (length ss < length as) $ fail ("Bad case: " ++ show ec)
+        tick stats (toAtom "E.Simplify.case-no-default") 
+        f (ECase e b as Nothing,[])
+    f (ECase e b [] (Just d),[]) | not (isLifted e) = do
+        tick stats (toAtom "E.Simplify.case-unlifted")
+        f (eLet b e d,[]) 
+        
+    f (ECase e (TVr 0 _) as (Just (ELetRec ds (ECase e' b' as' d'))),[]) | e == e' = do 
+        tick stats (toAtom "E.Simplify.case-merging") 
+        let nas' = filter ( (`notElem` map altHead as) . altHead) as' 
+        f (ELetRec ds  $ ECase e b' (as ++ nas') d',[])
+        
+    f (ec@ECase { eCaseScrutinee = el@(ELit l), eCaseAlts = [], eCaseDefault = Just e },[]) | isFullyConst el = do
+        tick stats (toAtom "E.Simplify.case-fully-const") 
+        cont (subst (eCaseBind ec) el e,[])
+    f (ec@ECase { eCaseScrutinee = el@(ELit l) },[]) = do
+        (x,as) <- match l (eCaseAlts ec) (eCaseDefault ec)
+        cont (eLet (eCaseBind ec) el (foldl eAp x as),[])
+        --liftM (mapFst $ eLet (eCaseBind ec) el) $ 
+    f (EError s t,xs@(_:_)) = do
+        ticks stats (length xs) (toAtom "E.Simplify.error-application") 
+        f (EError s (foldl eAp t xs),[])
+    f (ec@ECase { eCaseScrutinee = (EVar tvr)} ,[]) = do
+        e <- lookupBinding tvr
+        case e of 
+            IsBoundTo el@(ELit l) -> liftM (mapFst $ eLet (eCaseBind ec) el) $ match l (eCaseAlts ec) (eCaseDefault ec)
+            NotAmong na | ECase e b [] (Just d) <- ec { eCaseAlts =  filtAlts na $ eCaseAlts ec } ->  do 
+                tick stats (toAtom "E.Simplify.seq-evaled") 
+                f (eLet b e d,[]) 
+--    f ec@(ECase e b as@(Alt (LitCons n _ _) _:_) (Just d),[]) | Just ss <- getSiblings dataTable n, length ss <= length as = do
+ --       when (length ss < length as) $ fail ("Bad case: " ++ show ec)
+ --       tick stats (toAtom "E.Simplify.case-no-default") 
+--        f (ECase e b as Nothing,[])
+            _ -> cont (ec,[])
+    f (x@(EVar v),xs) = do
+        z <- applyRule' stats (so_rules sopts) v xs 
+        case z of
+            Just (x,xs) -> f (x,xs)
+            Nothing -> do
+                e <- lookupBinding v
+                case e of
+                    IsBoundTo exp | forceInline v -> do
+                        tick stats (toAtom $ "E.Simplify.inline.forced.{" ++ tvrShowName v  ++ "}")
+                        cont (exp,xs)
+                    IsBoundTo (EVar v') -> do
+                        tick stats (toAtom "E.Simplify.inline.copy-propagate") 
+                        f (EVar v',xs)
+                    IsBoundTo (ELit l) -> do
+                        tick stats (toAtom "E.Simplify.inline.constant-folding") 
+                        cont (ELit l,xs)
+                    IsBoundTo x@(EError s t) -> do
+                        tick stats (toAtom "E.Simplify.inline.error-folding") 
+                        ticks stats (length xs) (toAtom "E.Simplify.error-application") 
+                        f (EError s (foldl eAp t xs),[])
+                    IsBoundTo exp 
+                        | shouldInline exp xs -> do 
+                            let name = tvrShowName v
+                                name' = if  ("Instance@." `isPrefixOf` name) then "Instance@" else name 
+                            tick stats (toAtom $ "E.Simplify.inline.value.{" ++ name'  ++ "}")
+                            cont (exp,xs)
+                        | otherwise -> cont (x,xs)
+                    _ -> cont (x,xs)
+    f (x,xs) = cont (x,xs)
+    cont (x,xs) = do
+        x <- g' x
+        xs <- mapM g' xs
+        liftIO $ doCoalesce stats (x,xs)
+    isGood (LitCons _ (_:_) _) = False 
+    isGood _ = True
+    --match :: Lit E -> [(Pat E,E)] -> IO (E,[E])
+    match (LitCons c xs _) ((Alt (LitCons c' bs _) e):_) _ | c == c' = do
+        tick stats (toAtom $ "E.Simplify.known-case." ++ show c ) 
+        cont (ELetRec (zip bs xs) e,[])
+    match l ((Alt l' e):_) _ | litMatch l l' = do
+        tick stats (toAtom $ "E.Simplify.known-case." ++ show l') 
+        f (e,[])
+    --match l ((PatWildCard,e):_) = do
+    --    tick stats (toAtom "E.Simplify.known-case._") 
+    --    f (e,[ELit l])
+    match m (_:xs) d = match m xs d
+    match l [] (Just e) = do 
+        tick stats (toAtom "E.Simplify.known-case._") 
+        f (e,[])
+    match m [] Nothing = error $ "End of match: " ++ show m 
+        
+        
+    g' (EPrim p xs t) = do
+        xs' <- mapM g' xs
+        return $ EPrim p xs' t
+    g' (ELit (LitCons p xs t)) = do
+        xs' <- mapM g' xs
+        return $ ELit (LitCons p xs' t)
+    g' x = do
+        (x',[]) <- g (x,[])
+        return x'
+    g (ELam (TVr n t) e,[]) | n /= 0,  n `notElem` freeVars e = do
+        tick stats (toAtom "E.Simplify.blank-lam") 
+        return (ELam (TVr 0 t) e,[]) 
+    g (EPi (TVr n t) e,[]) | n /= 0,  n `notElem` freeVars e = do
+        tick stats (toAtom "E.Simplify.blank-pi") 
+        return (EPi (TVr 0 t) e,[]) 
+--    g (EPi (TVr (Just i) _) (EAp a (EVar (TVr (Just i') _))),[]) | i == i' && not (i `elem` freeVars a) = do
+--        tick stats (toAtom "E.Simplify.eta-reduce-pi") 
+--        g (a,[]) 
+--    g (ELam (TVr (Just i) _) (EAp a (EVar (TVr (Just i') _))),[]) | i == i' && not (i `elem` freeVars a) = do
+--        tick stats (toAtom "E.Simplify.eta-reduce-lam") 
+--        g (a,[]) 
+        
+    g (x@(EVar v),xs@[]) = do
+        e <- lookupBinding v
+        case e of
+            IsBoundTo (EVar v') -> do
+                tick stats (toAtom "E.Simplify.inline.copy-propagate") 
+                g (EVar v',xs)
+            IsBoundTo e | Just _ <- fullyConst e -> do
+                tick stats (toAtom $ "E.Simplify.inline.constant-folding") 
+                return (e,xs)
+            IsBoundTo e | Just (EVar _,_) <- from_unsafeCoerce e -> do
+                tick stats (toAtom "E.Simplify.inline.arg-unsafeCoerce") 
+                return (e,xs)
+            IsBoundTo (ELit l) | isGood l -> do
+                tick stats (toAtom "E.Simplify.inline.constant-folding2") 
+                return (ELit l,xs)
+            --IsBoundTo x@(EError {}) -> do
+            --    tick stats (toAtom "E.Simplify.error-folding") 
+            --    return (x,xs)
+            --Just z | sortTypeLike z -> do
+            --    tick stats (toAtom "E.Simplify.constant-folding") 
+            --    f (z,xs)
+            _ -> return (x,xs)
+    g (x,[]) = return (x,[])
+    forceInline x | Just n <- tvrName x, Just xs <- Map.lookup n funcProps  = toAtom "INLINE" `elem` xs
+    forceInline _ = False
+
+filtAlts ns (Alt (LitCons n _ _) _:as) | n `elem` ns  = filtAlts ns as
+filtAlts ns (a:as) = a:filtAlts ns as
+filtAlts ns [] = []
+
+litMatch (LitInt a _) (LitInt b _) = a == b
+--litMatch (LitFrac a _) (LitFrac b _) = a == b
+litMatch LitCons {} LitCons {} = False -- taken care of above
+litMatch x y = error $ "litMatch: " ++ show (x,y)
+-}
+    
+
+
+
+                {-
+                --Just (IsBoundTo n e) | isAtomic e -> do
+                --    mtick (toAtom "E.Simplify.inline.copy-propegate")
+                --    h  e xs' inb 
+                Just (IsBoundTo n e) |  length xs <= length xs' -> case x of
+                        ELit {} -> do
+                            mtick (toAtom "E.Simplify.inline.const")
+                            app (e,xs') 
+                        EPi {} -> do
+                            mtick (toAtom "E.Simplify.inline.const")
+                            app (e,xs') 
+                        EError {} -> do
+                            mtick (toAtom "E.Simplify.inline.error")
+                            app (e,xs') 
+                        EPrim {} | length xs > 0 -> do
+                            mtick (toAtom "E.Simplify.inline.prim")
+                            app (e,xs') 
+                        EVar {} -> do
+                            mtick (toAtom "E.Simplify.inline.simple")
+                            app (e,xs') 
+                        _ -> app (EVar v,xs')
+                    where (x,xs) = fromLam e
+                        
+                -}
addfile ./E/Shadow.hs
hunk ./E/Shadow.hs 1
+module E.Shadow(allShadow) where
+
+
+import E.E
+import qualified Data.Map as Map
+import Control.Monad.Reader
+import Data.FunctorM
+
+litSMapM f (LitCons s es t) = do 
+    t' <- f t 
+    es' <- mapM f es
+    return $ LitCons s es' t'
+litSMapM f l = fmapM f l
+
+
+allShadow :: E -> E 
+allShadow e  = f e (Map.empty,2) where
+    f :: E -> (Map.Map Int E,Int) -> E
+    f eo@(EVar (TVr { tvrIdent =  i})) = do
+        (mp,_) <- ask 
+        case Map.lookup i mp of 
+          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 Unknown = return Unknown
+    f e@(ESort {}) = return e
+    f (ELit l) = liftM ELit $ litSMapM f l 
+    f e = error $ "allShadow: " ++ show e
+    {-
+    f (ELetRec dl e) = do
+        (as,rs) <- liftM unzip $ mapMntvr (fsts dl) 
+        local (mconcat rs) $ do
+            ds <- mapM f (snds dl) 
+            e' <- f e
+            return $ ELetRec (zip as ds) e'
+    f ec@(ECase {}) = do
+        e' <- f $ eCaseScrutinee ec
+        (b',r) <- ntvr [] $ eCaseBind ec
+        d <- local r $ fmapM f $ eCaseDefault ec
+        let da (Alt (LitCons s vs t) e) = do
+                t' <- f t
+                (as,rs) <- liftM unzip $ mapMntvr vs
+                e' <- local (mconcat rs) $ f e
+                return $ Alt (LitCons s as t') e'
+            da (Alt l e) = do
+                l' <- fmapM f l 
+                e' <- f e 
+                return $ Alt l' e'
+        alts <- local r (mapM da $ eCaseAlts ec)
+        return  ECase { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts }  
+    lp lam (TVr n t) e | n == 0 || (n `notElem` freeVars e) = do
+        t' <- f t
+        e' <- f e
+        return $ lam (TVr 0 t') 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 = [ tvrNum x | x <- ts ]
+    -}
+    lp lam tvr e = do
+        (tv,r) <- ntvr tvr 
+        e' <- local r $ f e
+        return $ lam tv e'
+            
+    ntvr tvr@(TVr { tvrIdent = i, tvrType =  t }) = do 
+        t' <- f t
+        (_,i') <- ask  
+        let nvr = (tvr { tvrIdent =  i', tvrType =  t'})
+        return (nvr,\ (a,b) -> (Map.insert i (EVar nvr) a,i' + 2))
+        
+    
+
addfile ./E/Simplify.hs
hunk ./E/Simplify.hs 1
+module E.Simplify(simplify,SimpOpts(..)) where
+
+
+import Atom
+import Control.Monad.Trans
+import DataConstructors
+import Data.Monoid
+import E.E
+import E.LetFloat
+import E.PrimOpt
+import E.Rules
+import E.Subst
+import E.Traverse
+import E.TypeCheck
+import E.Values
+import FreeVars
+import GenUtil
+import HasSize
+import List
+import Monad
+import Name
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import Stats
+import E.Strictness as Strict
+import CanType
+
+inlineThreshold = 7
+
+shouldInline ELam {} [] = False  -- Lambda lifting will undo anyway
+shouldInline exp xs = safeToDup exp && size e + length as - length xs - sum (map (fromEnum . isFullyConst) xs) - 4 * fromEnum (whnfOrBot e) - 5 * isCombinator exp  < inlineThreshold   where
+    (e,as) = fromLam exp
+    isCombinator e = fromEnum $ IntMap.size (freeVs e) == 0
+
+--patBinds  PatWildCard  = 1
+--patBinds (PatLit (LitCons _ xs _)) = length xs
+--patBinds _ = 0
+
+--armMap :: (E -> E) -> Alt E -> Alt E
+--armMap f (p,e) | nb <= length ts = (p,foldr ELam (f e'') tsa) where 
+--    (e',ts) = fromLam e
+--    (tsa,tsb) = splitAt nb ts
+--    e'' = foldr ELam e' tsb
+--    nb = patBinds p 
+
+doSimplify sopts  stats (x,xs) = f (x,xs) where  
+    funcProps = so_properties sopts
+    dataTable = so_dataTable sopts
+--    f (ELam (TVr Nothing _) e,a:as) = do
+--        tick stats (toAtom "E.Simplify.beta-reduce") 
+--        f (e,as)
+--    f (EPi (TVr Nothing _) e,a:as) = do
+--        tick stats (toAtom "E.Simplify.pi-reduce") 
+--        f (e,as)
+    f (p@EPrim {},xs) = do
+        p' <- primOpt dataTable stats p 
+        cont (p',xs)
+    f (ELam tvr e,(a:as)) = do
+        tick stats (toAtom "E.Simplify.beta-reduce") 
+        f (subst tvr a e,as)   
+    f (EPi tvr e,(a:as)) = do
+        tick stats (toAtom "E.Simplify.pi-reduce") 
+        f (subst tvr a e,as)   
+    f (ECase e b as d,xs@(_:_)) = do
+        tick stats (toAtom "E.Simplify.case-application") 
+        f (ECase e b (map (\(Alt p e) -> Alt p $ foldl EAp e xs) as) (fmap (\e -> foldl EAp e xs) d) ,[])
+    f (ec@(ECase e _ _ _),[]) | isBottom e = do
+        tick stats (toAtom "E.Simplify.case-of-bottom") 
+        f (prim_unsafeCoerce e (typ ec),[])
+    f (ECase e b as (Just (ECase e' b' as' d')),[]) | e == e' = do 
+        tick stats (toAtom "E.Simplify.case-merging") 
+        let (nb,mdc)   
+                | tvrNum b == 0 = (b',id)
+                | tvrNum b' == 0 = (b,id)
+                | otherwise = (b,ELetRec [(b',EVar b)]) -- error "case-default-case: double bind"
+            nas' = filter ( (`notElem` map altHead as) . altHead) as' 
+        f (ECase e nb (as ++ nas') (fmap mdc d'),[])
+    f (oc@(ECase ic@(ECase e b as d) b' as' d'),[]) | length (filter (not . isBottom) (caseBodies ic)) <= 1 || all whnfOrBot (caseBodies ic) || all whnfOrBot (caseBodies oc) = do
+        tick stats (toAtom "E.Simplify.case-of-case") 
+        let f (Alt l e) = Alt l (g e)
+            g x = ECase x b' as' d'
+        cont (ECase e b (map f as) (fmap g d),[])      -- we duplicate code so continue for next renaming pass before going further.
+        
+    f ec@(ECase e b as@(Alt (LitCons n _ _) _:_) (Just d),[]) | Just ss <- getSiblings dataTable n, length ss <= length as = do
+        when (length ss < length as) $ fail ("Bad case: " ++ show ec)
+        tick stats (toAtom "E.Simplify.case-no-default") 
+        f (ECase e b as Nothing,[])
+    f (ECase e b [] (Just d),[]) | not (isLifted e) = do
+        tick stats (toAtom "E.Simplify.case-unlifted")
+        f (eLet b e d,[]) 
+        
+    --f (ECase e (TVr 0 _) as (Just (ELetRec ds (ECase e' b' as' d'))),[]) | e == e' = do 
+    --    tick stats (toAtom "E.Simplify.case-merging") 
+    --    let nas' = filter ( (`notElem` map altHead as) . altHead) as' 
+    --    f (ELetRec ds  $ ECase e b' (as ++ nas') d',[])
+        
+    f (ec@ECase { eCaseScrutinee = el@(ELit l), eCaseAlts = [], eCaseDefault = Just e },[]) | isFullyConst el = do
+        tick stats (toAtom "E.Simplify.case-fully-const") 
+        cont (subst (eCaseBind ec) el e,[])
+    f (ec@ECase { eCaseScrutinee = el@(ELit l) },[]) = do
+        (x,as) <- match l (eCaseAlts ec) (eCaseDefault ec)
+        cont (eLet (eCaseBind ec) el (foldl eAp x as),[])
+        --liftM (mapFst $ eLet (eCaseBind ec) el) $ 
+    f (EError s t,xs@(_:_)) = do
+        ticks stats (length xs) (toAtom "E.Simplify.error-application") 
+        f (EError s (foldl eAp t xs),[])
+--    f (ec@ECase { eCaseScrutinee = (EVar tvr)} ,[]) = do
+--        e <- lookupBinding tvr
+--        case e of 
+--            IsBoundTo el@(ELit l) -> liftM (mapFst $ eLet (eCaseBind ec) el) $ match l (eCaseAlts ec) (eCaseDefault ec)
+--            NotAmong na | ECase e b [] (Just d) <- ec { eCaseAlts =  filtAlts na $ eCaseAlts ec } ->  do 
+--                tick stats (toAtom "E.Simplify.seq-evaled") 
+--                f (eLet b e d,[]) 
+--    f ec@(ECase e b as@(Alt (LitCons n _ _) _:_) (Just d),[]) | Just ss <- getSiblings dataTable n, length ss <= length as = do
+ --       when (length ss < length as) $ fail ("Bad case: " ++ show ec)
+ --       tick stats (toAtom "E.Simplify.case-no-default") 
+--        f (ECase e b as Nothing,[])
+--            _ -> cont (ec,[])
+    f (x@(EVar v),xs) = do
+        z <- applyRule' stats (so_rules sopts) v xs 
+        case z of
+            Just (x,xs) -> f (x,xs)
+            Nothing -> do
+                e <- lookupBinding v
+                case e of
+                    IsBoundTo exp | forceInline v -> do
+                        tick stats (toAtom $ "E.Simplify.inline.forced.{" ++ tvrShowName v  ++ "}")
+                        cont (exp,xs)
+                    IsBoundTo (EVar v') -> do
+                        tick stats (toAtom $ "E.Simplify.inline.copy-propagate.head.{" ++ tvrShowName v' ++ "}") 
+                        f (EVar v',xs)
+                    IsBoundTo (ELit l) -> do
+                        tick stats (toAtom "E.Simplify.inline.constant-folding") 
+                        cont (ELit l,xs)
+                    IsBoundTo x@(EError s t) -> do
+                        tick stats (toAtom "E.Simplify.inline.error-folding") 
+                        ticks stats (length xs) (toAtom "E.Simplify.error-application") 
+                        f (EError s (foldl eAp t xs),[])
+                    IsBoundTo exp 
+                        | shouldInline exp xs -> do 
+                            let name = tvrShowName v
+                                name' = if  ("Instance@." `isPrefixOf` name) then "Instance@" else name 
+                            tick stats (toAtom $ "E.Simplify.inline.value.{" ++ name'  ++ "}")
+                            cont (exp,xs)
+                        | otherwise -> cont (x,xs)
+                    _ -> cont (x,xs)
+    f (x,xs) = cont (x,xs)
+    cont (x,xs) = do
+        x <- g' x
+        xs <- mapM g' xs
+        liftIO $ doCoalesce stats (x,xs)
+        --return (x,xs)
+    isGood (LitCons _ (_:_) _) = False 
+    isGood _ = True
+    --match :: Lit E -> [(Pat E,E)] -> IO (E,[E])
+    match m@(LitCons c xs _) ((Alt (LitCons c' bs _) e):rs) d | c == c' = do
+        tick stats (toAtom $ "E.Simplify.known-case." ++ show c ) 
+        cont (ELetRec (zip bs xs) e,[])
+            | otherwise = match m rs d
+    match m@(LitInt la _) ((Alt (LitInt lb _) e):rs) d | la == lb  = do
+        tick stats (toAtom $ "E.Simplify.known-case." ++ show la) 
+        f (e,[])
+            | otherwise = match m rs d
+    match l [] (Just e) = do 
+        tick stats (toAtom "E.Simplify.known-case._") 
+        f (e,[])
+    match m [] Nothing = error $ "End of match: " ++ show m 
+    match m as d = error $ "Odd Match: " ++ show ((m,getType m),as,d)
+        
+        
+    g' (EPrim p xs t) = do
+        xs' <- mapM g' xs
+        return $ EPrim p xs' t
+    g' (ELit (LitCons p xs t)) = do
+        xs' <- mapM g' xs
+        return $ ELit (LitCons p xs' t)
+    g' x = do
+        (x',[]) <- g (x,[])
+        return x'
+    g (ELam tvr@(TVr { tvrIdent = n}) e,[]) | n /= 0,  n `notElem` freeVars e = do
+        tick stats (toAtom "E.Simplify.blank-lam") 
+        return (ELam (tvr {tvrIdent = 0 }) e,[]) 
+    g (EPi tvr@(TVr { tvrIdent = n }) e,[]) | n /= 0,  n `notElem` freeVars e = do
+        tick stats (toAtom "E.Simplify.blank-pi") 
+        return (EPi (tvr { tvrIdent =  0 }) e,[]) 
+--    g (EPi (TVr (Just i) _) (EAp a (EVar (TVr (Just i') _))),[]) | i == i' && not (i `elem` freeVars a) = do
+--        tick stats (toAtom "E.Simplify.eta-reduce-pi") 
+--        g (a,[]) 
+--    g (ELam (TVr (Just i) _) (EAp a (EVar (TVr (Just i') _))),[]) | i == i' && not (i `elem` freeVars a) = do
+--        tick stats (toAtom "E.Simplify.eta-reduce-lam") 
+--        g (a,[]) 
+        
+    g (x@(EVar v),xs@[]) = do
+        e <- lookupBinding v
+        case e of
+            IsBoundTo (EVar v') -> do
+                tick stats (toAtom $ "E.Simplify.inline.copy-propagate.arg.{" ++ tvrShowName v' ++ "}") 
+                g (EVar v',xs)
+            IsBoundTo e | Just _ <- fullyConst e -> do
+                tick stats (toAtom $ "E.Simplify.inline.constant-folding") 
+                return (e,xs)
+            IsBoundTo e | Just (EVar _,_) <- from_unsafeCoerce e -> do
+                tick stats (toAtom "E.Simplify.inline.arg-unsafeCoerce") 
+                return (e,xs)
+            IsBoundTo (ELit l) | isGood l -> do
+                tick stats (toAtom "E.Simplify.inline.constant-folding2") 
+                return (ELit l,xs)
+            --IsBoundTo x@(EError {}) -> do
+            --    tick stats (toAtom "E.Simplify.error-folding") 
+            --    return (x,xs)
+            --Just z | sortTypeLike z -> do
+            --    tick stats (toAtom "E.Simplify.constant-folding") 
+            --    f (z,xs)
+            _ -> return (x,xs)
+    g (x,[]) = return (x,[])
+    forceInline x | Just n <- tvrName x, Just xs <- Map.lookup n funcProps  = toAtom "INLINE" `elem` xs
+    forceInline _ = False
+
+filtAlts ns (Alt (LitCons n _ _) _:as) | n `elem` ns  = filtAlts ns as
+filtAlts ns (a:as) = a:filtAlts ns as
+filtAlts ns [] = []
+
+litMatch (LitInt a _) (LitInt b _) = a == b
+--litMatch (LitFrac a _) (LitFrac b _) = a == b
+litMatch LitCons {} LitCons {} = False -- taken care of above
+litMatch x y = error $ "litMatch: " ++ show (x,y)
+
+--propRec stats =  itick stats (toAtom "E.Simplify.inline.copy-propagate") 
+ltcRec stats i =  ticks stats i (toAtom "E.Simplify.let-to-case") 
+
+
+data SimpOpts = SimpOpts {
+    so_properties :: Map.Map Name [Atom],
+    so_rules :: Rules,
+    so_boundVars :: Map.Map Int E, 
+    so_dataTable :: DataTable,
+    so_strictness :: Map.Map Int Strict.SA
+    }
+    {-! derive: Monoid !-}
+
+simplify :: SimpOpts -> Stats -> E -> IO E
+simplify sopts stats e = traverse travOptions { 
+    pruneRecord = varElim stats, 
+    trav_rules = so_rules sopts,
+    trav_strictness = so_strictness sopts,
+    letToCaseRecord = ltcRec stats,
+    propegateRecord = propRec stats }  f mempty smap e where
+    smap = Map.fromAscList [ (x,IsBoundTo y) |  (x,y) <- Map.toAscList $ so_boundVars sopts]
+    f n (x,xs) = do
+        (x',xs') <- doSimplify sopts stats (x,xs) 
+        return $ foldl EAp x' xs'
+                                  
addfile ./E/Strictness.hs
hunk ./E/Strictness.hs 1
+module E.Strictness where
+
+import Boolean.Algebra 
+import Prelude hiding((&&),(||),not,and,or,any,all)
+import E.E
+import Data.Monoid
+import DDataUtil()
+import MonoidUtil()
+import GenUtil
+import C.Prims
+import Control.Monad.Writer
+import FindFixpoint
+import Control.Monad.Identity
+import E.Values
+import E.Subst
+
+import qualified Data.Map as Map
+
+newtype Var = V Int
+    deriving(Eq,Ord)
+
+instance Show Var where
+    show (V x) = tvrShowName (tvr { tvrIdent = x }) 
+
+-- I believe this is a lattice, but I don't think it is bounded, and I could
+-- be wrong.
+
+data SA = 
+    S Int     -- Strict, argument is number of args guarenteed to be passed to it
+    | L       -- Lazy. We don't know whether it will be evaluated
+    | A       -- Absent. definitly not evaluated
+    | U [SA]  -- Unary Constructor.
+    | O Var Int Int -- depends on some other value, called with first int number of arguments and is the second ints argument number.
+    | SOr SA SA     -- A or B 
+    | SAnd SA SA    -- A and B
+    | Lam [SA]      -- Lambda Function
+    | If Var Int SA SA  -- if 
+        deriving(Ord,Eq,Show)
+
+type SAMap = Map.Map Var SA
+
+
+
+type CResult = [(Var,SA)]
+
+collectSolve :: E -> IO CResult
+collectSolve e = ans where
+    cr = collect mempty (tVr (-1) Unknown,e)
+    ans = E.Strictness.solve [ c  | c@(x,_) <- cr, x /= (V $ -1) ] 
+
+ 
+solve :: CResult -> IO CResult 
+solve vs = ans where
+    mp = Map.fromList [ ((x, case y of Lam _ -> True ; _ -> False) ,i) | (x,y) <- vs | i <- [0..] ]
+    wts = [ sol y | (_,y) <- vs]
+    ans = do
+        bs <- FindFixpoint.solve (Just "Strictness") L wts
+        return [ (x,b) |  (x,_) <- vs | b <- bs ]
+    getVal' x 
+        | Just i <- Map.lookup x mp = getVal i 
+        | otherwise = return L
+        
+    sol L = return L
+    sol A = return A
+    sol (S n) = return (S n)
+    sol (If v n a b) = do
+        x <- getVal' (v,False) 
+        case x of
+            S n' | n' >= n -> return a
+            _ -> return b
+    sol (O v a i) = do
+        x <- getVal' (v,True)
+        case x of 
+            Lam as | length as <= a && i < length as -> sol (as !! i)
+            _ -> return L
+    sol (SAnd a b) = do
+        a' <- sol a 
+        b' <- sol b
+        return (sand a' b')
+    sol (SOr a b) = do
+        a' <- sol a 
+        b' <- sol b
+        return (sor a' b')
+    sol (Lam xs) = do
+        xs' <- mapM sol xs
+        return $ Lam xs'
+
+
+
+collect :: SAMap -> (TVr,E) -> CResult
+collect env e = ans where
+    ans = execWriter (g e)
+    f :: E -> Writer CResult SAMap
+    g :: (TVr,E) -> Writer CResult SAMap
+    --f (EVar (TVr i _)) = (Map.single i (S 0),[]) 
+    f (EPrim _ as _) = return (andSA (Map.empty:(map (arg (S 0)) as))) 
+    f (ELit (LitCons _ as _)) = return $ andSA (mempty:(map (arg L) as))
+    f (EPi (TVr { tvrType = a }) b) = return $ arg L a `andsa` arg L b
+    f (ELit (LitInt {})) = return mempty
+    f e | (EVar (TVr { tvrIdent = n } ),as) <- fromAp e = return $ andSA  ((Map.singleton (V n) (S (length as))):[ arg (O (V n) (length as) i) a | a <- as | i <- [0..] ])
+    f ec@(ECase e b as d) = do
+        fe <- f e  
+        fb <- mapM f (caseBodies ec)  
+        cb <- finS (caseBinds ec) (orSA fb)  
+        return $ fe `andsa` cb
+    f (EError {}) = return mempty  -- TODO
+    f e@(ELam {}) | (b,as) <- fromLam e = f b >>= fin as
+    f (ELetRec ds e) = do
+        ds' <- mapM g ds 
+        fe <- f e
+        fin (fsts ds)  $ andSA (fe:ds')
+    f e@(EAp a b)  = case runIdentity $ app (fromAp e) of 
+            EAp a' b' | a == a' && b == b' -> error $ "Strictness.f: " ++ show e
+            e -> f e
+    f e = error $ "Strictness: " ++ show e 
+    fin ts sm = do 
+        tell [ (V i,Map.findWithDefault A (V i) sm) | (TVr { tvrIdent = i }) <- ts]
+        return $ Map.fromAscList [ (V i,L) | (V i,v) <- Map.toAscList sm, i `notElem` map tvrNum ts] 
+    finS ts sm = do
+        return $ Map.fromAscList [ (V i,v) | (V i,v) <- Map.toAscList sm, i `notElem` map tvrNum ts]
+    g (t,e)  = ans where
+        (b,as) = fromLam e 
+        ans = do 
+            samap <- f b
+            when (not $ null as) $ tell [(V (tvrNum t),Lam [ Map.findWithDefault A (V t) samap |  TVr { tvrIdent = t } <- as])]
+            return $ Map.fromAscList [ (V i,saIf (V $ tvrNum t) (length as) v L) | (V i,v) <- Map.toAscList samap, i `notElem` map tvrNum as]
+    arg sa (EVar (TVr { tvrIdent = i })) = Map.singleton (V i) sa 
+    arg sa (ELit _) = mempty
+    arg sa (EPi _ _) = mempty
+    arg sa (EPrim (APrim (PrimPrim "unsafeCoerce") _) [x] _) = arg sa x
+    arg sa e = error $ "Strictness.arg: " ++ show (sa,e)
+    
+
+saIf _ _ a b | a == b = a 
+saIf x y a b = If x y a b
+
+andSA,orSA :: [SAMap] -> SAMap
+andSA = foldl andsa mempty
+orSA = foldl1 orsa 
+andsa,orsa :: SAMap -> SAMap -> SAMap
+andsa = squiddle (&&)
+orsa = squiddle (||)
+
+squiddle f ma mb = Map.unionWith f ma' mb' where
+    nk = snub (Map.keys ma ++ Map.keys mb) 
+    tm = Map.fromList [ (k,A) | k <- nk]
+    ma' = ma `Map.union` tm
+    mb' = mb `Map.union` tm
+
+instance SemiBooleanAlgebra (SAMap,[(Var,SA)]) where
+    (x,y) && (x',y') = (Map.unionWith (&&) x x',y ++ y')
+    (x,y) || (x',y') = (Map.unionWith (||) x x',y ++ y')
+
+instance SemiBooleanAlgebra SA where 
+    a && b = sand a b
+    a || b = sor a b
+
+-- Can this be simplified? is this a lattice?
+
+sand a b = (if x == SAnd a b then sand' b a else x ) where
+    x = sand' a b
+    sand' a b | a == b = a
+    sand' (S a) (S b) = S (max a b)
+    sand' (S a) _ = S a
+    sand' _ (S a) = S a
+    sand' A x = x
+    sand' L L = L
+    sand' a b = SAnd a b
+--sand' (a `SAnd` b) c = sand a (sand b c) 
+--sand (U sa) (U sb) = U (zipWith sand sa sb)
+--sand (U a) _ = U a
+--sand _ (U a) = U a
+
+
+
+sor a b = if x == SOr a b then sor' b a else x where
+    x = sor' a b 
+    sor' a b | a == b = a
+    sor' (S a) (S b) = S (min a b)
+    sor' A (S _) = L
+    sor' L (S _) = L
+    sor' L _ = L
+    sor' A A = A
+    sor' a b = SOr a b
+    --sor' (a `SOr` b) c = sor' a (sor' b c) 
+
+
+
addfile ./E/Subst.hs
hunk ./E/Subst.hs 1
+module E.Subst(subst,subst',substMap,substMap',noShadow,doSubst,substMap'',litSMapM, app, substLet) where
+
+
+-- This is tricky.
+
+import CanType
+import Control.Monad.Reader
+import Data.FunctorM
+import Data.Monoid
+import E.E
+import E.Values
+import FreeVars
+import GenUtil
+import List
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import qualified Data.Map as Map
+import Stats
+import Atom
+
+
+
+substLet :: [(TVr,E)] -> E -> E 
+substLet ds e  = ans where
+    (as,nas) = partition (isAtomic . snd) (filter ((/= 0) . tvrNum . fst) ds)
+    ans = eLetRec nas (substMap' (Map.fromList [ (n,e) | (TVr { tvrIdent = n },e) <- as]) 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 (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars (getType w) ++ freeVars e ]) 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 (Map.insert i (Just w) $ Map.fromList [ (x,Nothing) | x <- freeVars (getType w) ++ freeVars e ]) e 
+
+
+substMap :: IM.IntMap E -> E -> E
+substMap im e = substMapScope im (IS.unions $ freeVars e: (map freeVars (IM.elems im))) e
+
+
+litSMapM f (LitCons s es t) = do 
+    t' <- f t 
+    es' <- mapM f es
+    return $ LitCons s es' t'
+litSMapM f l = fmapM f l
+
+
+substMapScope :: IM.IntMap E -> IS.IntSet -> E -> E
+substMapScope im ss e = substMapScope' False im ss e
+
+
+noShadow :: E -> E 
+noShadow e = doSubst False False (Map.fromList [ (x,Nothing) | x <- freeVars e ]) e
+
+allShadow :: E -> E
+allShadow e = doSubst False True (Map.fromList [ (x,Nothing) | x <- freeVars e ]) e
+
+substMap' :: Map.Map Int E -> E -> E
+substMap' im e = doSubst False False (Map.fromList [ (x,Map.lookup x im) | x <- (freeVars e ++ freeVars (Map.elems im)) ]) e
+
+-- | doesn't seed with free variables.
+substMap'' :: Map.Map Int E -> E -> E
+substMap'' im = doSubst False False (Map.map Just im) -- (Map.fromAscList [ (x,Just y) | (x,y) <- Map.toAscList im ]) e
+
+-- Monadic code is so much nicer
+doSubst :: Bool -> Bool -> Map.Map Int (Maybe E) -> E -> E 
+doSubst substInVars allShadow bm e  = f e bm where
+    f :: E -> Map.Map Int (Maybe E) -> E
+    f eo@(EVar tvr@(TVr { tvrIdent = i, tvrType =  t })) = do
+        mp <- ask 
+        case Map.lookup i mp of 
+          Just (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 dl e) = do
+        (as,rs) <- liftM unzip $ mapMntvr (fsts dl) 
+        local (mconcat 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 [] $ eCaseBind ec
+        d <- local r $ fmapM f $ eCaseDefault ec
+        let da (Alt (LitCons s vs t) e) = do
+                t' <- f t
+                (as,rs) <- liftM unzip $ mapMntvr vs
+                e' <- local (mconcat rs) $ f e
+                return $ Alt (LitCons s as t') e'
+            da (Alt l e) = do
+                l' <- fmapM f l 
+                e' <- f e 
+                return $ Alt l' e'
+        alts <- (mapM da $ eCaseAlts ec)
+        return  ECase { eCaseScrutinee = e', eCaseDefault = d, eCaseBind = b', eCaseAlts = alts }  
+    lp lam tvr@(TVr { tvrIdent = n, tvrType = t}) e | n == 0 || (allShadow && n `notElem` freeVars e) = do
+        t' <- f t
+        e' <- local (Map.insert n Nothing) $ f e
+        return $ lam (tvr { tvrIdent =  0, tvrType =  t'}) e'
+    lp lam tvr e = do
+        (tv,r) <- ntvr [] 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 = [ tvrNum x | x <- ts ]
+            
+    --mapMntvr [] = return []
+    --mapMntvr (t:ts) = do
+    --    (t',r) <- ntvr t 
+    --    ts' <- local r (mapMntvr ts)
+    --    return ((t',r):ts')
+    --ntvr :: TVr -> Map Int (Maybe E) -> (TVr, Map Int (Maybe E) -> Map Int (Maybe E))
+    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
+        i' <- mnv allShadow xs i
+        let nvr = (tvr { tvrIdent =  i', tvrType =  t'})
+        case i == i' of
+            True -> return (nvr,Map.insert i (Just $ EVar nvr))
+            False -> return (nvr,Map.insert i (Just $ EVar nvr) . Map.insert i' Nothing)
+        
+    
+
+mnv allShadow xs i ss 
+    | allShadow = nv ss 
+    | i <= 0 || i `Map.member` ss = nv (Map.fromList [ (x,undefined) | x <- xs ] `mappend` ss)
+    | otherwise = i
+        
+
+nv ss = v (2 * (Map.size ss + 1)) where 
+    v n | n `Map.member` ss = v (n + 2)
+    v n = n
+
+nv' ss = v (2 * (Map.size ss + 1)) where 
+    v n | (Just Nothing) <- Map.lookup n ss = v (n + 2)
+    v n = n
+
+-- swiss army knife of substitution
+substMapScope' :: Bool -> IM.IntMap E -> IS.IntSet -> E -> E
+substMapScope' allShadow im ss e = doSubst False allShadow (Map.fromList $ [ (x,Nothing) | x <- IS.toList ss ] ++ [ (x,Just y) |  (x,y) <-  IM.toList im] ) e
+
+app (e,[]) = return e
+app (e,xs) = app' e xs
+
+app' (ELit (LitCons n xs t)) (a:as)  = do
+    mtick (toAtom $ "E.Simplify.typecon-reduce.{" ++ show n ++ "}" ) 
+    app (ELit (LitCons n (xs ++ [a]) (eAp t a)),as)
+app' (ELam tvr e) (a:as) = do
+    mtick (toAtom "E.Simplify.beta-reduce") 
+    app (subst 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
+    caseBodiesMapM f ec 
+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 
+
+{-
+substMapScope' allShadow im ss e = s im ss e where
+    s im ss ev@(EVar (TVr i t)) = case IM.lookup i im of
+        Just x -> x
+        Nothing -> ev -- EVar (TVr (Just i) (s im ss t))
+    s im ss (ELam tvr e) = lp im ss ELam tvr e
+    s im ss (EPi tvr e)  =  lp im ss EPi tvr e
+    s im ss (ELetRec dl e) =   ELetRec dl' (s' e) where
+        s' = s im' ss'
+        (ss', dl', im') = foldl f (ss,[], im) dl  
+        f  (ss,dl,im) ((TVr (i) t),e) |  i `IS.member` ss  =  (IS.insert v ss,(ntvr, s' e):dl,IM.insert i (EVar ntvr) im) where
+            v = nv ss
+            ntvr = TVr ( v) (s' t)
+        f  (ss,dl,im) ((TVr (i) t),e) = (IS.insert i ss,(ntvr, s' e):dl,IM.insert i (EVar ntvr) im) where
+            ntvr = TVr ( i) (s' t)
+        f _ _ = error "invalid ELetRec"
+    s im ss (EAp a b) = EAp (s im ss a) (s im ss b)
+    --s im ss (ELit (LitCons x es e)) = ELit (LitCons x (map (s im ss) es) (s im ss e))
+    s im ss (ELit l) = ELit $ sLit im ss l
+    s im ss (EError x e) = EError x (s im ss e)
+    s im ss (EPrim x es e) = EPrim x (map (s im ss) es) (s im ss e)
+    --s im ss ec@(ECase {}) = ECase { eCaseScrutinee = (s im ss $ eCaseScrutinee ec) } where
+           --v [ (sPat im ss p, s im ss e) | (p,e) <- alt]
+    s _ _ e = e
+    sLit im ss (LitCons x es e) = LitCons x (map (s im ss) es) (s im ss e)
+    sLit im ss l = fmap (s im ss) l
+    nv ss = v (2 * (IS.size ss + 1)) where 
+        v n | n `IS.member` ss = v (n + 2)
+        v n = n
+    lp im ss lam (TVr (i) t) e | allShadow && not (i `IS.member` freeVars e) = lam ntvr (s (IM.delete i im) ss e) where
+        t' =  (s im ss t)
+        ntvr =  (TVr 0 t')
+    lp im ss lam (TVr 0 t) e = lam (TVr 0 (s im ss t)) (s im ss e)
+    lp im ss lam (TVr (i) t) e | allShadow || i `IS.member` ss = r  where
+        v = nv (ss `IS.union` freeVars t')        
+        t' =  (s im ss t)
+        ntvr =  (TVr ( v) t')
+        r = lam ntvr (s (IM.insert i (EVar ntvr) im) (IS.insert v ss) e)
+    lp im ss lam (TVr j@(i) t) e = lam ntvr (s (IM.insert i (EVar ntvr) (IM.delete i im)) (IS.insert i ss) e) where
+        t' =  (s im ss t)
+        ntvr =  (TVr j t')
+-}
addfile ./E/Subst.hs-boot
hunk ./E/Subst.hs-boot 1
+module E.Subst where
+
+
+import {-# SOURCE #-} E.E
+
+subst :: E.E.TVr -> E.E.E -> E.E.E -> E.E.E
+--subst :: TVr -> E -> E -> E
addfile ./E/Traverse.hs
hunk ./E/Traverse.hs 1
+
+module E.Traverse(TravM, newVarName, lookupBinding, newBinding, traverse, renameTraverse, renameTraverse', TravOptions(..), Binding(..), travOptions, emapE, emapE') where
+
+import E.E
+import E.Rules
+import E.TypeCheck
+import Data.FunctorM
+
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.Monoid
+import E.Inline
+import E.Strictness as Strict
+import E.Values
+import FreeVars
+import GenUtil
+import Name
+import NameMonad
+import qualified Data.Map as Map
+
+-- 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)
+
+renameTraverse e = (e',c) where
+    (e',MInt c) = runWriter $ traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> lift (tell (MInt 1)) >> (return $ foldl EAp x xs)) mempty mempty  e
+renameTraverse' e = e' where
+    e' = traverse travOptions { pruneUnreachable = Nothing } (\_ (x,xs) -> (return $ foldl EAp x xs)) mempty mempty  e
+
+data  TravOptions m = TravOptions {
+    pruneUnreachable :: Maybe [Int],
+    pruneRecord :: Int -> m (),
+    propegateRecord :: Int -> m (),
+    letToCaseRecord :: Int -> m (),
+    trav_rules :: Rules,
+    trav_strictness :: Map.Map Int Strict.SA,
+    _hiddenTricky :: m ()    -- ^ This ensures types are not ambiguous if we don't fill in the monadic routines
+    }
+
+travOptions :: Monad m => TravOptions m 
+travOptions = TravOptions {
+    pruneUnreachable = Just mempty,
+    pruneRecord = \_ -> return (),
+    propegateRecord = \_ -> return (),
+    letToCaseRecord = \_ -> return (),
+    trav_rules = mempty,
+    trav_strictness = mempty,
+    _hiddenTricky = return ()
+    }
+{-
+travOptionsI :: TravOptions Identity 
+travOptionsI = TravOptions {
+    pruneUnreachable = Just mempty,
+    pruneRecord = \_ -> Identity ()
+    }
+-}
+type Subst = Map.Map Int E  -- Map apply anywhere. so should range only over atoms
+type InScope = Map.Map Int Binding
+data Binding = NotAmong [Name] | IsBoundTo E | NotKnown
+
+--newtype TravM m a = TravM (StateT (Map.Map Int Binding) m a)
+--    deriving(Monad,MonadTrans,Functor,MonadIO)
+newtype TravM m a = TravM (ReaderT (Map.Map Int Binding) (NameMT Int m) a)
+    deriving(Monad,Functor,MonadIO)
+
+instance MonadTrans TravM where
+    lift a = TravM $ lift $ lift a
+
+fromTravM (TravM x) = x
+
+{-# INLINE newBinding #-}
+newBinding :: Monad m => E -> TravM m (TVr,E) 
+newBinding e = do
+    v <- newVarName 
+    return (tVr ( v) (typeInfer mempty e),e)
+
+{-# INLINE lookupBinding #-}
+lookupBinding :: Monad m => TVr -> TravM m Binding 
+lookupBinding (TVr { tvrIdent = n }) = TravM $ do
+    x <- ask
+    return (maybe NotKnown id $  Map.lookup n x)
+
+{-# INLINE newVarName #-}
+newVarName :: Monad m => TravM m Int
+newVarName = TravM $ do
+    newName
+    --m <- get  
+    --let nv = newVar m
+    --put (Map.insert nv NotKnown m)
+    --return nv
+
+{-
+
+{-# INLINE newVar #-}
+newVar ss = newVar' ss (2 * Map.size ss + 2)
+newVar' ss n | n <= 0 || n `Map.member` ss  = v $ (2 * Map.size ss + 2) + (n + (n `mod` 2))  where 
+    v n | n `Map.member` ss = v (n + 2)
+    v n = n
+newVar' _ n = n
+
+-}
+
+traverse :: (MonadFix m,Monad m) => TravOptions m -> (Int -> (E,[E]) -> TravM m E) -> Subst -> (Map.Map Int Binding) -> E -> m E 
+traverse (tOpt :: TravOptions m) func subst smap e = runNameMT $ initNames >> runReaderT (f e) (smap,subst,0::Int)  where
+    initNames = do
+        addNames $ freeVars e
+        addNames (Map.keys subst)
+        addNames (Map.keys smap)
+    f :: E -> ReaderT (Map.Map Int Binding, Subst, Int) (NameMT Int m) E  
+    f' e = do
+        local (\ (a,b,c) -> (a,b,c + 1)) $  f e
+        --(y,z,n) <- get
+        --put (y,z,n + 1) 
+        --put (y,z,n)
+        --return x
+    f  e | (x,xs) <- fromAp e = do
+        xs' <- mapM l xs
+        x' <- g x 
+        (m,p,lvl) <- ask
+        (z) <- lift $ runReaderT (fromTravM $ func lvl (x',xs')) m
+        --put (m,p,lvl)
+        return z
+    g  e@(EVar (TVr { tvrIdent = n, tvrType =  t})) = do 
+        (_,im,lvl) <- ask 
+        case Map.lookup n im of
+            Just n'@(EVar t) | tvrNum t == n -> return $ n'
+            Just n' -> do 
+                lift $ lift $  propegateRecord tOpt 1     
+                return $ n'
+            Nothing -> return e 
+    g  (ELit (LitCons n xs t)) = do
+        xs' <- mapM l xs
+        t' <- f' t
+        return $ ELit (LitCons n xs' t')
+    g (ELit l) = return $ ELit l
+    g (EError x t) = do
+        t' <- f' t
+        return $ EError x t'
+    g (EPrim n es t) = do
+        es' <- mapM l es
+        t' <- f' t
+        return $ EPrim n es' t'
+    g (ECase e b as d) = do
+        e' <- f e
+        (ob,b') <- ntvr f' b 
+        localSubst [(ob,EVar b')] $ do 
+            as' <- mapM (da [ v  | EVar v <- [e',EVar b']] [ v  | EVar v <- [e,EVar b]])   as 
+            d' <- localVars [ (tvrNum v,NotAmong [ n | Alt (LitCons n _ _) _ <- as]) | EVar v <- [e',EVar b'] ] $ fmapM f d 
+            return $ ECase e' b' as' d' 
+    g (ELam tvr e) = lp f' ELam tvr e
+    g (EPi tvr e) = lp f EPi tvr e
+    g (ELetRec ds e) = z (basicDecompose  (pruneUnreachable tOpt) (trav_rules tOpt) e ds) e  where
+        z [] e = f e
+        z (Left (tvr,x):rs) e | worthStricting x, Just (S _) <- Map.lookup (tvrNum tvr) (trav_strictness tOpt)  = do
+            (n,tvrn) <- ntvr f' tvr 
+            x' <- f x
+            nr <- localSubst [(n,EVar tvrn)]   (z rs e)
+            lift $ lift $  letToCaseRecord tOpt 1     
+            return $ eStrictLet tvrn x' nr
+        z (Left (tvr,x):rs) e = do
+            (n,tvrn) <- ntvr f' tvr 
+            x' <- f x
+            nr <- localVars [(tvrNum tvrn, IsBoundTo x')] $ localSubst [(n,EVar tvrn)]   (z rs e)
+            return $ eLetCoalesce [(tvrn,x')] nr
+        z (Right ds:rs) e = do
+            ds' <- mapM (ntvr f' . fst) ds 
+            --let ds'' = inlineDecompose (pruneUnreachable tOpt) e ds
+            --lift $ lift $  pruneRecord tOpt (length ds - length ds'') 
+            let (fz,gz)  = unzip [ ((n',NotKnown),(n,EVar tvr)) |  (n,tvr@(TVr  { tvrIdent =  n' })) <- ds']
+            localVars fz $ localSubst gz $ do
+                ds''' <- sequence [ f x >>= return . (,) tvr | (_,tvr) <- ds' | (_,x) <- ds ]
+                nr <- (z rs e)
+                return $ eLetCoalesce ds''' nr
+                --h ds'' (z rs e) []
+    {-
+    g (ELetRec ds e) = do
+        ds' <- mapM ( ntvr f' . fst) ds
+        let ds'' = inlineDecompose (pruneUnreachable tOpt) e ds
+        lift $ lift $  pruneRecord tOpt (length ds - length ds'') 
+        let (fz,gz)  = unzip [ ((n',NotKnown),(n,EVar tvr)) |  (n,tvr@(TVr  n' _)) <- ds']
+        localVars fz $ localSubst gz $ do
+            h ds'' e []
+    -}
+    g x@(ESort {}) = return x
+    g e = error $ "g: " ++ show e
+    eLetCoalesce ds (ELetRec ds' e) = ELetRec (ds ++ ds') e
+    eLetCoalesce ds e = ELetRec ds e
+    l x@EAp {} = f x
+    l x = g x
+    da vs _ (Alt p@(LitCons n xs t) l) = do
+        t' <- f' t
+        xs' <-  mapM (ntvr f') xs
+        localVars [ (tvrNum v, IsBoundTo (ELit $ LitCons n (map (EVar . snd) xs') t')) |  v <- vs ] $ do
+            localSubst [ (x,EVar y) | (x,y) <- xs'] $ do 
+                l' <- f l 
+                return (Alt (LitCons n (snds xs') t') l')
+    da vs _ (Alt p l) = do
+        p' <- fmapM f' p
+        localVars [ (tvrNum v, IsBoundTo (patToLitEE p')) |  v <- vs ] $ do
+            l' <- f l 
+            return (Alt p' l')
+    --lp elam (TVr Nothing t) e = do
+    --    t' <- f' t
+    --    e' <- f e
+    --    return $ elam (TVr Nothing t') e'
+    lp fg elam tv e = do
+        (n,tvr@(TVr { tvrIdent = n' })) <- ntvr fg tv  
+        e' <- localVars [(n',NotKnown)] $ localSubst [(n,EVar tvr)]   (f e)
+        return $ elam tvr e'
+    lb n me n' ne (m,im,lvl) = (Map.insert n me m,if n' /= 0 then Map.insert n' ne im else im ,lvl)
+    localVars ex x = do
+        let ex' = Map.fromList [ (a,b) |  (a,IsBoundTo b) <- ex, isAtomic b ]
+            z (EVar (TVr { tvrIdent = n })) | Just v <- Map.lookup n ex' = v
+            z e = e
+        r <- local (\ (a,b,c) ->  (Map.fromList ex `mappend` a, fmap z  b ,c)) x
+        return r
+    localSubst (ex :: [(Int,E)]) x = do
+        r <- local (\ (a,b,c) ->  (a, Map.fromList ex `mappend` b ,c)) x
+        return r
+    ntvr fg tvr@(TVr { tvrIdent = 0, tvrType = t}) = do
+        t' <- fg t
+        --let tvr = (TVr 0 t')
+        return (0,tvr { tvrType = t'})
+    ntvr fg ttvr@(TVr { tvrIdent = n, tvrType = t}) = do
+        n' <- if n > 0 then uniqueName  n else newName  
+        t' <- fg t
+        let tvr = ttvr { tvrIdent = n', tvrType = t' } 
+        return (n:: Int,tvr:: TVr)
+    h [] e ds = do
+        e' <- e
+        return $ eLetCoalesce ds e'
+    h (((TVr { tvrIdent = n }),x):dds) e ds = do 
+        (_,tm,_) <- ask
+        let (Just (EVar nt)) = Map.lookup n tm 
+        x' <- f x
+        localVars [(tvrNum nt, IsBoundTo x')] $ h dds e ((nt,x'):ds)
+        --case isAtomic x' of 
+        --    False -> do 
+                --modify (\ (a,b,c) -> (Map.insert (tvrNum nt) (IsBoundTo x') a,b,c)) 
+        --        localVars [(tvrNum nt, IsBoundTo x')] $ h dds e ((nt,x'):ds)
+        --    True -> do
+        --        localSubst [(n,x')] $ h dds e ((nt,x'):ds)
+    {-
+    h (Left ((TVr (Just n) _),x):dds) e ds = do 
+        (_,tm,_) <- get
+        let (Just nt) = Map.lookup n tm 
+        x' <- f x
+        modify (\ (a,b,c) -> (Map.insert (tvrNum nt) (Just x') a,b,c)) 
+        h dds e ((nt,x'):ds)
+    h (Right ds:dds) e rs = do 
+        let l ((TVr (Just n) _),x) = do
+                (_,tm,_) <- get
+                let Just nt = Map.lookup n tm 
+                x' <- f x
+                return (nt,x')
+        ds' <- mapM l ds
+        h dds e (ds' ++ rs)
+    da vs _ (Alt p@(LitCons n xs t) l) = do
+        localVars [ (tvrNum v, IsBoundTo (ELit $ patToLitEE p)) |  v <- vs ] $ do
+            t' <- f' t
+            xs' <-  mapM (ntvr f') xs
+            localSubst [ (x,EVar y) | (x,y) <- xs'] $ do 
+                l' <- f l 
+                return (Alt (LitCons n (snds xs') t') l')
+    da vs _ (Alt p l) = do
+        localVars [ (tvrNum v, IsBoundTo (ELit $ patToLitEE p)) |  v <- vs ] $ do
+            p' <- fmapM f' p
+            l' <- f l 
+            return (Alt p' l')
+    -}
+
+
+worthStricting x = isLifted x && not (isELit x)
+
addfile ./E/TypeCheck.hs
hunk ./E/TypeCheck.hs 1
+module E.TypeCheck(typ, eAp, sortStarLike, sortTypeLike,  sortTermLike, inferType, typeInfer, typeInfer') where
+
+import CanType
+import DataConstructors
+import Doc.DocLike
+import Doc.PPrint
+import Doc.Pretty
+import E.E                 
+import E.Eval(strong)
+import E.Pretty
+import E.Subst
+import GenUtil
+import MonadUtil
+import Monad(when)
+
+
+
+
+
+
+
+
+
+
+
+withContextDoc s a = withContext (render s) a 
+
+-- | 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 $ typ s
+    fc (ELit (LitCons _ es t)) = valid t >> mapM_ valid es >> (strong' t)
+    fc e@(ELit _) = let t = typ e in valid t >> return t
+    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) = valid at >> rfc' [ d | d@(v,_) <- ds, tvrNum v /= n ] b
+    --fc (ELam tvr@(TVr n at) b) = valid at >> rfc' [ d | d@(v,_) <- ds, tvrNum 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, tvrNum v /= n ] b 
+        strong' $ EPi tvr b' 
+    --fc (EAp (EPi tvr e) b) = rfc (subst tvr b e)
+    fc (EAp a b) = do
+        a' <- rfc a 
+        case followAliases dataTable a' of 
+            (EPi tvr@(TVr { tvrType =  t}) v) -> do
+                valid t
+                withContextDoc (hsep [text "Application: ", parens $ prettyE a <> text "::" <> prettyE a', parens $ prettyE b]) $ fceq ds b t
+                b' <- if sortStarLike t then strong' b else return b
+                nt <- return (subst tvr b' v)
+                valid nt
+                return nt
+            x -> fail $ "App: " ++ render (tupled [ePretty x,ePretty a, ePretty b])  
+    fc (ELetRec vs e) = do
+        let ck (tv@(TVr { tvrType =  t}),e) = withContextDoc (hsep [text "Checking Let: ", parens (pprint tv),text  " = ", parens $ prettyE e ])  $  valid' nds t >>  fceq nds e t
+            nds = vs ++ ds 
+        mapM_ ck vs 
+        when (hasRepeatUnder (tvrNum . 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 e b as (Just d)) | sortTypeLike e  = do   -- TODO - we should substitute the tested for value into the default type.
+        et <- rfc e
+        eq et (getType b)
+        dt <- rfc d
+        --bs <- mapM rfc (caseBodies ec)  -- these should be specializations of dt
+        mapM_ (calt e) as
+        --eqAll bs
+        verifyPats (casePats ec)
+        ps <- mapM (strong' . getType) $ casePats ec
+        eqAll (et:ps) 
+        return dt
+    fc ec@(ECase e b _ _) = do
+        et <- rfc e
+        eq et (getType b)
+        bs <- mapM rfc (caseBodies ec)
+        eqAll bs
+        verifyPats (casePats ec)
+        ps <- mapM (strong' . getType) $ casePats ec
+        eqAll (et:ps) 
+        return (head bs)
+    fc e = failDoc $ text "what's this? " </> (prettyE e)
+    calt (EVar v) (Alt l e) = do
+        let nv =  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 _ xs _) = when (hasRepeatUnder id (filter (/= 0) $ map tvrNum xs)) $ fail "Case pattern is non-linear"
+    verifyPats' _ = return ()
+        
+        
+         
+    {-
+    fc (ECase _ []) = fail "Case with no alternatives"
+    -- when checking typecases, we must check that the specialization of the default case matches each of the other alternatives.
+    fc (ECase e alts) | sortTypeLike e = rfc e >>= \et -> mapM (cp et) alts >>= \as ->  return (last as) where
+        cp et (PatLit l,e) = do
+            withContextDoc (hsep [text "Case Pattern: ", parens $ prettyE et, parens $ prettyE (ELit l)]) $ eq et (getType  l) 
+            e' <- rfc e 
+            return (discardArgs (length es) e') where -- TODO - check these.
+                es = case l of (LitCons _ es _) -> es ; _ -> []
+        cp _ (PatWildCard,e') = rfc (eAp e' e)
+    fc (ECase e alts) = rfc e >>= \et -> mapM (cp et) alts >>= \as@(a:_) -> eqAll  as >> return a where
+        cp et (PatLit l,e) = do
+            withContextDoc (hsep [text "Case Pattern: ", parens $ prettyE et, parens $ prettyE (ELit l)]) $ eq et (getType l) 
+            e' <- rfc e 
+            return (discardArgs (length es) e')  where -- TODO - check these. 
+                es = case l of (LitCons _ es _) -> es ; _ -> []
+        cp _ (PatWildCard,e') = rfc (eAp e' e)
+    -}
+    eqAll ts = withContextDoc (text "eqAll" </> list (map prettyE ts)) $ foldl1M_ eq ts  
+    valid s = valid' ds s
+    valid' nds s 
+        | s == eBox = return ()
+        | Unknown <- s = fail "valid: Unknown"
+        | otherwise =  withContextDoc (text "valid:" <+> prettyE e) (do t <- inferType' nds s;  valid' nds t)
+    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 (followAliases dataTable e1)
+            Left s -> failDoc $ hsep [text "eq:",text s, align $ vcat [ prettyE (e1),prettyE (e2) ]  ] 
+
+--        let x 
+--            --  | e1 == e2 = e1
+--              | allShadow e1 == allShadow e2 = return e1
+--            --  | e1 == tInt || e2 == tInt = return e1
+--              | otherwise = failDoc $ hsep [text "eq:",{- tupled (map pprint $ fsts nds), -} tupled [ prettyE (e1),prettyE (e2) ], tupled [ prettyE (allShadow e1), prettyE (allShadow e2)] {- , tupled [ text (show e1), text (show e2)] -}  ] 
+--        x
+--    -- | Check that the type of e1 is the same as t2 within the given context
+    fceq nds e1 t2 = do
+        withContextDoc (hsep [text "fceq:", parens $ prettyE e1, parens $ prettyE t2]) $ do
+        t1 <- inferType' nds e1
+        eq' nds t1 t2
+        --flip (eq' nds) t2 t
+    --eq t1 t2 | Just _ <- E.Eval.unify (smplE t1) (smplE t2) = return (smplE t1) 
+    --eq t1 t2 | Just _ <- E.Eval.unify (smplE t2) (smplE t1) = return (smplE t1) 
+    --eq t1 t2 | smplE t1 == smplE t2 = return t1
+    --eq t1 t2 | t1 == tInt || t2 == tInt = return t1  --TODO - hack.
+    --eq t1 t2 | Left d <- E.Eval.unify (smplE t1) (smplE t2) = failDoc $ hsep [text "eq:", tupled [text d, prettyE (smplE t1),prettyE (smplE t2) ] ] 
+    --eq t1 t2  = failDoc $ hsep [text "eq:", tupled [ prettyE (smplE t1),prettyE (smplE t2) ] ] 
+    --valid s | s == eBox = return ()
+    --valid Unknown = fail "valid: Unknown"
+    --valid e = withContextDoc (text "valid:" <+> prettyE e) (rfc e >>= valid)
+
+
+-- | 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
+
+typeInfer'' :: ContextMonad String m => DataTable -> [(TVr,E)] -> E -> m E
+typeInfer'' dataTable ds e = rfc e where
+    inferType' ds e = typeInfer'' 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 $ typ s
+    fc (ELit (LitCons _ es t)) = (strong' t)
+    fc e@(ELit _) = strong' (typ 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) =  rfc' [ d | d@(v,_) <- ds, tvrNum v /= n ] b
+    fc (ELam tvr@(TVr { tvrIdent = n, tvrType =  at}) b) = do
+        at' <- strong' at
+        b' <- rfc' [ d | d@(v,_) <- ds, tvrNum v /= n ] b 
+        return (EPi (tVr n at') b') 
+    --fc (EAp (EPi tvr e) b) = rfc (subst tvr b e)
+    fc (EAp a b) = do
+        a' <- rfc a 
+        case followAliases dataTable a' of 
+            (EPi tvr@(TVr { tvrType = t}) v) -> do
+                --withContextDoc (hsep [text "Application: ", parens $ prettyE a <> text "::" <> prettyE a', parens $ prettyE b]) $ fceq ds b t
+                b' <- if sortStarLike t then strong' b else return b
+                return (subst tvr b' v)
+            x -> fail $ "App: " ++ render (tupled [ePretty x,ePretty a, ePretty 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 ec@(ECase e b as (Just d)) | sortTypeLike e  = do   -- TODO - we should substitute the tested for value into the default type.
+        dt <- rfc' [ d | d@(v,_) <- ds, tvrNum b /= tvrNum v ] d
+        return dt
+    fc ec@(ECase e b _ _) = do
+        --bs <- mapM rfc (caseBodies ec)
+        --return (head bs)
+        rfc (head $ caseBodies ec)
+    fc e = failDoc $ text "what's this? " </> (prettyE e)
+
+
+
addfile ./E/Values.hs
hunk ./E/Values.hs 1
+module E.Values where
+
+import Char
+import C.Prims
+import Data.FunctorM
+import E.E
+import FreeVars
+import Name
+import qualified Data.Set as Set
+import VConsts
+import Ratio
+
+
+eIf e a b = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 tBool),  eCaseAlts =  [Alt vTrue a,Alt vFalse b], eCaseDefault = Nothing }
+
+eTuple []  = vUnit
+eTuple [e] = e
+eTuple es = ELit $ LitCons (toTuple (length es)) es (ltTuple ts) where
+    ts = map typ es
+    
+eTuple' es = ELit $ LitCons (unboxedNameTuple DataConstructor (length es)) es (ltTuple' ts) where
+    ts = map typ es
+
+ltTuple ts = ELit $ LitCons (nameTuple TypeConstructor (length ts)) ts eStar
+ltTuple' ts = ELit $ LitCons (unboxedNameTuple TypeConstructor (length ts)) ts eStar
+
+toList :: Monad m => E -> m  [E]
+toList (ELit (LitCons n [e,b] _)) | vCons == n = toList b >>= \x -> return (e:x)
+toList (ELit (LitCons n [] _)) | vEmptyList == n = return []
+toList _ = fail "toList: not list"
+
+toString x = toList x >>= mapM fromChar where
+    fromChar (ELit (LitCons dc [ELit (LitInt ch t)] _ot)) | dc == dc_Char && t == tCharzh = return (chr $ fromIntegral ch)
+    fromChar _ = fail "fromChar: not char"
+
+--toString :: Monad m => E -> m String
+--toString (ELit (LitCons n [(ELit (LitInt c t)),b] _)) | vCons == n, t == tChar  = toString b >>= \x -> return (chr (fromIntegral c):x)
+----toString (ELit (LitCons n [] _)) | toAtom "[]" == n = return []
+--toString e | e == eNil tString = return ""
+--toString _ = fail "toString: not string"
+
+--fromString :: String -> E
+--fromString (x:xs) = eCons (ELit (LitInt (fromIntegral $ ord x) tChar)) $ fromString xs
+--fromString "" = eNil tString
+
+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
+
+dc_Char = toName DataConstructor ("Prelude","Char")
+dc_Rational = toName DataConstructor ("Ratio",":%") 
+dc_Addr = toName DataConstructor ("Jhc.Addr","Addr")
+dc_JustIO = toName DataConstructor ("Jhc.IO", "JustIO")
+
+instance ToE Char where 
+    toE ch = ELit (LitCons dc_Char [toEzh ch] tChar)
+    typeE _ = tChar
+
+instance ToE Rational where
+    toE rat = ELit (LitCons dc_Rational [toE (numerator rat), toE (denominator rat)] tRational) 
+    typeE _ = tRational
+
+instance ToE Integer where 
+    toE ch = ELit (litCons DataConstructor ("Prelude","Integer") [toEzh ch] tInteger)
+    typeE _ = tInteger
+
+instance ToE Int where 
+    toE ch = ELit (litCons DataConstructor ("Prelude","Int") [toEzh ch] 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 TypeConstructor ("Prelude","[]") [typeE (undefined::a)] eStar)   
+    
+
+--eInt x = ELit $ LitInt x tInt
+
+eCons x xs = ELit $ LitCons vCons [x,xs] (typ xs)
+eNil t = ELit $ LitCons vEmptyList [] t
+
+eCaseTup e vs w = ECase e (tVr 0 (typ e)) [Alt (LitCons (toTuple (length vs)) vs (typ e)) w] Nothing
+eCaseTup' e vs w = ECase e (tVr 0 (typ e)) [Alt (LitCons (unboxedNameTuple DataConstructor (length vs)) vs (typ e)) w] Nothing
+
+eJustIO w x = ELit (LitCons dc_JustIO [w,x] (ELit (LitCons (toName TypeConstructor ("Jhc.IO","IOResult")) [typ x] eStar))) 
+tIO t = ELit (LitCons (toName TypeConstructor ("Jhc.IO", "IO")) [t] eStar)
+
+eCase e alts Unknown = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 (typ e)), eCaseDefault = Nothing, eCaseAlts =  alts }
+eCase e alts els = ECase { eCaseScrutinee = e, eCaseBind = (tVr 0 (typ e)), eCaseDefault = Just els, eCaseAlts =  alts }
+--    f (p@(PatWildCard,_):_) = [p]
+--    f (p:ps) = p:f ps
+--    f [] = [(PatWildCard,eLam (TVr Nothing (typ e)) els)] 
+
+-- This takes care of types right away, it simplifies various other things to do it this way.
+eLet (TVr { tvrIdent = 0 }) _ = id 
+eLet t@(TVr { tvrType =  ty}) e | sortStarLike ty && isAtomic e = subst t e  
+eLet t e = ELetRec [(t,e)]
+
+fullyConst :: Monad m => E -> m ()
+fullyConst (ELit (LitCons _ [] _)) = return ()
+fullyConst (ELit (LitCons _ xs _)) = mapM_ fullyConst xs 
+fullyConst ELit {} = return ()
+fullyConst (EPi (TVr { tvrType = t }) x) = do
+    fullyConst t 
+    fullyConst x
+fullyConst _ = fail "not fully constant"
+
+isFullyConst :: E -> Bool
+isFullyConst = maybe False (const True) . fullyConst
+
+isAtomic :: E -> Bool
+--isAtomic e | sortTypeLike e = True
+isAtomic EVar {}  = True
+isAtomic e = isFullyConst e
+
+
+isBottom EError {} = True
+isBottom _ = False
+--isBottom e@ECase {} = eCase
+
+isLifted x = sortTermLike x
+
+-- Note: This does not treat lambdas as whnf
+whnfOrBot :: E -> Bool
+whnfOrBot (EError {}) = True
+whnfOrBot (ELit (LitCons _ xs _)) = all isAtomic xs
+whnfOrBot (EPi (TVr { tvrIdent =  j, tvrType =  x }) y) | not (j `Set.member` freeVars y) = isAtomic x && isAtomic y
+whnfOrBot e = isAtomic e
+
+safeToDup e = whnfOrBot e || isELam e || isEPi e  
+
+eStrictLet t@(TVr { tvrType =  ty }) v e | sortStarLike ty && isAtomic v = subst t v e  
+eStrictLet t v e = ECase v t [] (Just e)
+
+prim_seq a b | isWHNF a = b
+prim_seq a b = ECase a (tVr 0 (typ a)) [] (Just b)
+
+prim_unsafeCoerce e t = p e' where 
+    (_,e',p) = unsafeCoerceOpt $ EPrim (primPrim "unsafeCoerce") [e] t
+from_unsafeCoerce (EPrim (APrim (PrimPrim "unsafeCoerce") _) [e] t) = return (e,t)
+from_unsafeCoerce _ = fail "Not unsafeCoerce primitive"
+
+rawType s  = ELit (LitCons (toName RawType s) [] eStar)
+    
+unsafeCoerceOpt (EPrim (APrim (PrimPrim "unsafeCoerce") _) [e] t) = 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 (LitCons x y _)) t = (n,ELit (LitCons x y t),id)
+    f n e t | typ e == t = (n,e,id)
+    f n e t = (n,e,flip prim_unsafeCoerce t)
+unsafeCoerceOpt e = (0,e,id)
+    
+prim_integralCast e t = EPrim (primPrim "integralCast") [e] t
+from_integralCast (EPrim (APrim (PrimPrim "integralCast") _) [e] t) = return (e,t)
+from_integralCast _ = fail "Not integralCast primitive"
+
+tPtr t = ELit (LitCons (toName TypeConstructor ("Foreign.Ptr","Ptr")) [t] eStar)
+
+--prim_const rs s t = EPrim (APrim (CConst s t)) 
+
+--isAtomic (ELit (LitInt {})) = True
+--isAtomic (ELit (LitChar {})) = True
+--isAtomic (ELit (LitFrac {})) = True
+--isAtomic (ELit (LitCons _ [] _)) = True
+--isAtomic _ = False
+
+caseBodiesMapM :: Monad m => (E -> m E) -> E -> m E 
+caseBodiesMapM f (ECase e b as d) = do
+    let g (Alt l e) = f e >>= return . Alt l
+    as' <- mapM g as
+    d' <- fmapM f d 
+    return $ ECase e b as' d'
+caseBodiesMapM _ _ = error "caseBodiesMapM"
addfile ./FastMutInt.hs
hunk ./FastMutInt.hs 1
+{-# OPTIONS -cpp #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Unboxed mutable Ints
+
+-- arch-tag: cc964025-cbad-4910-8f56-5d54d5b1a006
+
+
+{-# OPTIONS -cpp #-}
+module FastMutInt(
+	FastMutInt, newFastMutInt,
+	readFastMutInt, writeFastMutInt
+  ) where
+
+
+
+--  #define SIZEOF_HSINT 4
+
+
+
+
+import GHC.Base
+import GHC.IOBase
+import Storable
+
+sSIZEOF_HSINT = sizeOf (undefined :: Int)
+
+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
+
+newFastMutInt :: IO FastMutInt
+newFastMutInt = IO $ \s ->
+  case newByteArray# size s of { (# s, arr #) ->
+  (# s, FastMutInt arr #) }
+  where I# size = sSIZEOF_HSINT
+
+{-# INLINE readFastMutInt  #-}
+readFastMutInt :: FastMutInt -> IO Int
+readFastMutInt (FastMutInt arr) = IO $ \s ->
+  case readIntArray# arr 0# s of { (# s, i #) ->
+  (# s, I# i #) }
+
+{-# INLINE writeFastMutInt  #-}
+writeFastMutInt :: FastMutInt -> Int -> IO ()
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
+  case writeIntArray# arr 0# i s of { s ->
+  (# s, () #) }
+
addfile ./FindFixpoint.hs
hunk ./FindFixpoint.hs 1
+module FindFixpoint(Ms, getVal, solve) where
+
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.IntSet as IntSet
+import Data.Graph(stronglyConnComp, SCC(..),flattenSCCs)
+import GenUtil
+import Monad(liftM)
+import Data.Array.IO
+import System.IO.Unsafe
+import CharIO
+import Array
+
+
+
+
+
+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]
+
+
addfile ./FixpointFinder.hs
hunk ./FixpointFinder.hs 1
+module FixpointFinder(Ms, Ms', getVal', solve', getVal, solve) where
+-- This can be sped up by taking dependencies into account.
+-- I designed the interface so hopefully changes can be limited to
+-- this module.
+
+import Control.Monad.Reader
+import Control.Monad.Writer
+import Data.Map as Map hiding((!),map) 
+import Seq
+import Data.Set as Set
+import Data.IntSet as IntSet
+import Data.Graph(stronglyConnComp, SCC(..),flattenSCCs)
+import DDataUtil
+import GenUtil
+import Monad(liftM)
+import Data.Array.IO
+import System.IO.Unsafe
+import CharIO
+import Array
+import GHC.Exts
+import Data.IORef
+
+
+{-
+data FFEnv a b = FFEnv { 
+        ffarray :: IOArray Int (b,[Int]), 
+        ffmap :: Map a Int
+    }
+
+newtype  Ms a b c = Ms (FFEnv a b -> WriterT (Seq Int) IO c)
+
+
+instance Monad (Ms a 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 (\_ -> lift (CharIO.putErrDie x))
+
+
+instance Functor (Ms a b) where
+    fmap = liftM
+
+getVal :: (Eq b,Ord a,Show a) => a -> Ms a b b
+getVal x = Ms $ \ff -> do
+    --let ind = unsafePerformIO (putErrLn $ "Lookup... " ++ show x) `seq` Map.find x (ffmap ff) 
+    let ind =  Map.find x (ffmap ff) 
+    tell (Seq.single ind)
+    (n,_) <- lift $ readArray (ffarray ff) ind 
+    return n
+
+solve :: (Show a,Show b,Ord a, Eq b) => b -> [(a,Ms a b b)] -> IO [(a,b)]
+solve _ [] = return []
+solve empty vs = do 
+    let len = length vs
+    CharIO.putStrLn $ "solve: " ++ show len
+    arr <- newArray (0::Int,len - 1) (empty,[])
+    let aarr = listArray (0::Int,len -1) (fsts vs)
+    let as =  [ (a,i,mb ff) | (a,Ms mb) <- vs | i <- [0..] ]
+        mp = Map.fromList [ (a,i) | (a,i,_) <- as ]
+        ff = FFEnv { ffarray = arr, ffmap = mp }
+    let s (a,n,fn) = do
+            (r,is) <- runWriterT fn 
+            writeArray arr n (r,snub (Seq.toList is))
+            --print (a,r)
+            if (r /= empty) 
+                then return [n]
+                else return []
+    cs <- fmap (Set.fromList . concat) $ mapM s as
+    cs <- return $ Set.fromAscList [0..len - 1]
+    CharIO.putStrLn $ "solve initial changed: " ++ show (Set.size cs) 
+    let z (a,n,fn) = readArray arr n >>= \(_,ds) -> return ((a,n,fn),ds) 
+    rs <- mapM z as 
+    let as' = concatMap f $ stronglyConnComp [ ((a,n,fn),n,ds) | ((a,n,fn),ds) <- rs ] where
+                f (AcyclicSCC x) = [x]
+                f (CyclicSCC xs) = xs
+        (_,sn,_) = head as'
+    let f _ cs | Set.isEmpty cs = return ()
+        f ((a,n,fn):rs) cs = do
+            when (n == sn) $ do
+                CharIO.putStrLn $ "Iteration... " ++ (show $ Set.size cs) 
+                --mapM_ (\n ->  readArray arr n >>= \(x,_) ->  CharIO.print (aarr!n,x))  (Set.toList cs)    
+            (v,ls) <- readArray arr n 
+            if any (`Set.member` cs) ls  then do
+                (r,is) <- runWriterT fn 
+                if r /= v then 
+                    writeArray arr n (r,snub (Seq.toList is)) >> 
+                        --print (a,r) >> 
+                           f rs (cs `Set.union` Set.single n)  
+                 else f rs (cs Set.\\  Set.single n)
+              else  f rs (cs Set.\\  Set.single n)
+                
+    f (cycle as') cs 
+    let g (a,n,_) = do
+            (v,_) <- readArray arr n 
+            return  (a,v)
+    mapM g as 
+    
+-}
+{-
+    return $ g vs (Map.fromList [ (a,empty) | (a,_) <- vs ]) [] where
+        
+    g ((a,Ms mb):vs) m rs = g vs m (r:rs) where
+        r = (a,Ms mb, Seq.toList ds, b')
+        (b',ds) = runWriter (mb m)  
+        
+    g [] _ rs | z `seq` True = f xs nm [] where  
+        xs = concatMap f $ stronglyConnComp [ ((a,ds,m),a,ds) | (a,m,ds@(_:_),_) <- rs ] where
+                f (AcyclicSCC x) = [x]
+                f (CyclicSCC xs) = xs
+        nm = Map.fromList [ (a,b) | (a,_,_,b) <- rs]
+        z = unsafePerformIO  $ mapM print [ (a,ds) | (a,ds,_) <- xs ]
+        
+        f ((a,_,Ms mb):vs) m t = f vs m' (if  not theSame then (a,b'):t else t) where
+            theSame = b == b'
+            m' = if theSame then m else Map.insert a b' m
+            Just b = Map.lookup a m
+            (b',_) = runWriter (mb m)  
+        f [] m [] = Map.toList m
+        f [] m zs | unsafePerformIO (mapM_ print (fsts zs) >> print ([length zs]) ) `seq` True = f xs m []
+
+-}
+
+--data unboxed Mode = Waiting | InProgress | RecursiveLoop 
+
+newtype (Ord a, Eq b) => Ms a b c = Ms (WriterT (Seq a) ((->) (Map a b))  c)
+    deriving (Monad,Functor)
+
+intNubRev :: [Int] -> [Int]
+intNubRev xs = f xs [] IntSet.empty where
+    f [] ys _ = ys 
+    f (x:xs) ys m 
+        | x `IntSet.member` m = f xs ys m 
+        | otherwise = f xs (x:ys) (IntSet.insert x m)
+
+getVal :: (Eq b,Ord a) => a -> Ms a b b
+getVal x = Ms $ do
+    tell (Seq.single x)
+    m <- ask
+    Just v <- return $ Map.lookup x m 
+    return v
+
+solve :: (Show a,Show b,Ord a, Eq b) => b -> [(a,Ms a b b)] -> IO [(a,b)]
+solve empty vs = return $ g vs (Map.fromList [ (a,empty) | (a,_) <- vs ]) [] where
+    g ((a,Ms mb):vs) m rs = g vs m (r:rs) where
+        r = (a,Ms mb, Seq.toList ds, b')
+        (b',ds) = runWriterT mb m  
+    g [] _ rs  = f xs nm [] where  
+        xs = concatMap f $ stronglyConnComp [ ((a,ds,m),a,ds) | (a,m,ds@(_:_),_) <- rs ] where
+                f (AcyclicSCC x) = [x]
+                f (CyclicSCC xs) = xs
+        nm = Map.fromList [ (a,b) | (a,_,_,b) <- rs]
+        
+        f ((a,_,Ms mb):vs) m t = f vs m' (if  not theSame then (a,b'):t else t) where
+            theSame = b == b'
+            m' = if theSame then m else Map.insert a b' m
+            Just b = Map.lookup a m
+            (b',_) = runWriterT mb m  
+        f [] m [] = Map.toList m
+        f [] m zs | unsafePerformIO (mapM_ CharIO.print (if length zs < 10 then  zs else []) >> CharIO.print ([length zs]) ) `seq` True = f xs m []
+
+
+data Env b  = Env {-# UNPACK #-} !(IOArray Int b) {-# UNPACK #-} !(IOArray Int (IntSet)) !Int
+newtype Ms' b c = Ms' (IO c)
+    deriving(Monad,Functor)
+
+{-
+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' :: Env b -> Int -> Ms' b b 
+getVal' (Env arr ref self) n = Ms' $  do
+    s <- readArray ref n 
+    --unless (self `IntSet.member` s) 
+    writeArray ref n $ (IntSet.insert self s)
+    readArray arr n 
+    
+    
+
+solve' :: (Eq b) => b -> [Env b -> Ms' b b] -> IO [b]
+solve' (empty :: b) vs = do
+    CharIO.putErrLn $ "Solver: " ++ show (length vs)
+    let len = length vs
+    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
+            CharIO.putErr $ " " ++ show (IntSet.size s)
+            li (reverse xs) IntSet.empty
+        li (i:rs) s = do
+            b <- readArray arr i
+            b'<- (fna Array.! i :: IO b)  
+            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
+    CharIO.putErrLn $ " Done."
+    mapM (readArray arr)  [0 .. len - 1]
+-- The kind inference monad
+    
+{-
+    let f as [] 0# _ _  = return ()  
+        f as [] n ds l = do
+            CharIO.putErrLn ("Iteration... " ++ show (I# n)) 
+            let xs = concatMap z scc
+                z (AcyclicSCC x) = [x]
+                z (CyclicSCC xs) = xs
+                scc =  stronglyConnComp ds
+                g (AcyclicSCC (i,fn)) = do
+                    b <- fn    
+                    writeArray arr i b
+                g (CyclicSCC xs) = CharIO.putErr "LI: " >> li xs xs 0# >> CharIO.putErrLn "" 
+            writeIORef ref []
+            mapM_ g scc  
+
+            f xs xs 0# [] l
+            --mapM CharIO.print (map (map fst . z) scc) 
+            {-
+            case l of 
+                0# -> do
+                    mapM_ g scc
+                    f xs xs 0# [] (l +# 1#)
+                5# -> f as as 0# [] 0#
+                _ ->  f as as 0# [] (l +# 1#)
+            -}
+        f as ((i,fn):rs) n ds l = do
+            b <- readArray arr i 
+            writeIORef ref [-1]
+            b' <- fn 
+            nds <- readIORef ref 
+            case b == b' of
+                True -> f as rs n (((i,fn),i,nds):ds) l
+                False -> do
+                    writeArray arr i b'
+                    f as rs (n +# 1#)  (((i,fn),i,nds):ds) l
+        li _ [] 0# = return ()
+        li xs [] n = CharIO.putErr ("(" ++ show (I# n) ++ ")") >>   li xs xs 0#
+        li xs ((i,fn):rs) n = do
+            b <- readArray arr i
+            b' <- fn 
+            case b == b' of
+                True -> li xs rs n 
+                False -> do
+                    writeArray arr i b'
+                    li xs rs (n +# 1#) 
+    f as as 0# [] ()
+    mapM (readArray arr)  [0 .. len - 1]
+-- The kind inference monad
+
+data KiEnv  = KiEnv {
+    kiContext :: [String],
+    kiEnv :: IORef KindEnv,
+    kiSubst :: IORef Subst,
+    kiVarnum :: IORef Int
+    }
+
+newtype KI a = KI (KiEnv -> IO a)-- -> (a, State))
+
+
+instance Monad KI where
+    return a = KI (\_ -> return a) 
+    KI comp >>= fun
+        = KI (\v  -> comp v >>= \r -> case fun r   of KI x -> x v) 
+    fail x = KI (\s -> fail (unlines $ reverse (x:kiContext s)))
+
+data State = State {
+      env :: KindEnv,     -- the environment of kind assumptions 
+      subst :: Subst     -- the current substitution
+   }
+
+-}
addfile ./FlagDump.flags
hunk ./FlagDump.flags 1
+# dump-flags
+
+!Front End 
+renamed code after uniqueness renaming 
+parsed  parsed code 
+derived show generated derived instances 
+imports show in scope names for each module
+exports show which names are exported from each module
+scc-modules show strongly connected modules in dependency order 
+defs Show all defined names in a module
+
+
+!Type Checker
+kind    show results of kind inference for each module
+dcons   data constructors
+class-summary summary of all classes
+class detailed information on each class
+instance show instances
+bindgroups show bindgroups
+types display unified type table containing all defined names
+all-kind show unified kind table after everything has been typechecked
+all-dcons show unified data constructor table 
+all-types show unified type table, after everything has been typechecked
+sigenv initial signature environment
+srcsigs processed signatures from source code
+program impl expls, the whole shebang.
+decls processed declarations
+aspats show as patterns
+tyvar show original tyvars rather than renaming them.
+
+
+!Intermediate code
+lambdacube show intermediate lambda cube code
+lambdacube-before-lift show intermediate lambda cube code just before lambda lifting
+pass show optimization passes over intermediate code
+datatable show data table of constructors
+optimization-stats show combined stats of optimization passes 
+rules show all rules
+
+
+!Grin code
+tags list of all tags and their types 
+grin-preeval show grin code just before eval/apply inlining
+grin show final grin code
+steps show interpreter go
+eval show detailed eval inlining info
+
+!General 
+@verbose progress
+@veryverbose progress stats
+progress show basic progress indicators
+stats show extra information about stuff
addfile ./FlagOpts.flags
hunk ./FlagOpts.flags 1
+# -f code options 
+
+!Code Options
+inline-pragmas use inline pragmas
+rules use rules 
+wrapper wrap main in exception handler
+float-in perform float inward transform
+
+lint perform lots of extra type checks 
+
+
+!Default settings
+@default inline-pragmas rules wrapper float-in
addfile ./FreeVars.hs
hunk ./FreeVars.hs 1
+
+module 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 
+
addfile ./FrontEnd/Class.hs
hunk ./FrontEnd/Class.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              Mark Jones and The Hatchet Team 
+                                (see file Contributors)
+
+        Module:                 Class
+
+        Description:            Code for manipulating the class hierarchy and 
+                                qualified types.
+
+                                The main tasks implemented by this module are:
+                                        - context reduction
+                                        - context spliting
+                                        - defaulting
+                                        - entailment of class constraints
+                                        - class hierarchy representation and
+                                          manipulation
+
+        Primary Authors:        Mark Jones, Bernie Pope
+
+        Notes:                  See the files License and License.thih 
+                                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/)
+
+-------------------------------------------------------------------------------}
+
+-- TODO this, of everything desperatly needs to be rewritten the most. 
+
+module Class(
+    addClassToHierarchy,
+    addInstancesToHierarchy,
+    printClassHierarchy,
+    instanceToTopDecls,
+    entails,
+    ClassHierarchy,
+    ClassRecord(..),
+    reduce,
+    split,
+    instanceName,
+    defaultInstanceName,
+    printClassSummary,
+    addOneInstanceToHierarchy,
+    findClassRecord,
+    asksClassRecord,
+    classRecords,
+    makeClassHierarchy,
+    splitReduce,
+    topDefaults
+    ) where
+
+import Binary
+import Control.Monad.Identity
+import Control.Monad.Writer
+import Data.FiniteMap  
+import Data.Generics
+import Data.Monoid
+import DDataUtil
+import Doc.PPrint
+import GenUtil(concatInter) 
+import GenUtil(snub)
+import HsSyn    
+import KindInfer
+import List((\\), partition)
+import MapBinaryInstance()
+import Maybe
+import Monad
+import MonoidUtil
+import Name
+import PPrint    
+import qualified Data.Map as Map
+import Representation 
+import Type     
+import TypeUtils
+import Utils        
+import VConsts
+import HasSize
+
+--------------------------------------------------------------------------------
+
+-- Instance
+type Inst  = Qual Pred
+
+
+bySuper :: ClassHierarchy -> Pred -> [Pred]
+bySuper h p@(IsIn c t)
+ = p : concat (map (bySuper h) supers)
+   where supers = [ IsIn c' t | c' <- supersOf h c ]
+
+byInst             :: Monad m => Pred -> Inst -> m [Pred]
+byInst p (ps :=> h) = do u <- matchPred h p
+                         return (map (apply u) ps)
+
+matchPred :: Monad m => Pred -> Pred -> m Subst
+matchPred x@(IsIn c t) y@(IsIn c' t')
+      | c == c'   = match t t'
+      | otherwise = fail $ "Classes do not match: " ++ show (x,y)
+
+reducePred :: Monad m => ClassHierarchy -> Pred -> m [Pred]
+reducePred h p@(IsIn c t) 
+    | Just x <- foldr (|||) Nothing poss = return x
+    | otherwise = fail "reducePred"
+ where poss = map (byInst p) (instsOf h c)
+       Nothing ||| y = y
+       Just x  ||| y = Just x
+
+-----------------------------------------------------------------------------
+
+entails :: ClassHierarchy -> [Pred] -> Pred -> Bool
+entails h ps p = any (p `elem`) (map (bySuper h) ps) ||
+           case reducePred h p of
+             Nothing -> False
+             Just qs -> all (entails h ps) qs
+
+-----------------------------------------------------------------------------
+
+-- the new class hierarchy
+
+
+-- classname (superclasses, instances, properly qualified type-sigs of methods)
+
+data ClassRecord = ClassRecord {
+    className :: Class,
+    classSrcLoc :: SrcLoc,
+    classSupers :: [Class],
+    classInsts :: [Inst],
+    classAssumps :: [Assump],
+    classDerives :: [Inst]
+    } deriving(Typeable,Data)
+    {-! derive: GhcBinary !-}
+
+newClassRecord c = ClassRecord {
+    className = c,
+    classSrcLoc = bogusASrcLoc,
+    classSupers = [],
+    classInsts = [],
+    classAssumps = [],
+    classDerives = []
+    }
+
+combineClassRecords cra crb | 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 = snub $ classAssumps cra ++ classAssumps crb,
+    classDerives = snub $ classDerives cra ++ classDerives crb
+    }
+
+--([Class], [Inst], [Assump])
+
+newtype ClassHierarchy = ClassHierarchy (Map.Map Class ClassRecord)
+    deriving (Binary,HasSize)
+    
+instance Monoid ClassHierarchy where
+    mempty = ClassHierarchy mempty
+    mappend (ClassHierarchy a) (ClassHierarchy b) = ClassHierarchy $ Map.unionWith combineClassRecords a b
+
+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 
+
+supersOf :: ClassHierarchy -> Class -> [Class]
+supersOf ch c = asksClassRecord ch c classSupers
+
+instsOf :: ClassHierarchy -> Class -> [Inst]
+instsOf ch c = asksClassRecord ch c classInsts
+
+
+showInst :: Inst -> String 
+showInst = PPrint.render . pprint
+        
+showPred :: Pred -> String
+showPred (IsIn c t)
+   = show c ++ " " ++ (pretty t)
+
+makeDeriveInstances :: [Pred] -> Type -> [Class] -> [Inst]
+makeDeriveInstances context t [] = []
+makeDeriveInstances context t (c:cs)
+   | c `elem` derivableClasses
+        = (context :=> IsIn c t) : makeDeriveInstances context t cs
+   | otherwise
+        = error $ "makeDeriveInstances: attempt to make type " ++ pretty t ++
+                  "\nan instance of a non-derivable class " ++ show c
+
+toHsName (x,y) = Qual (Module x) (HsIdent y)
+instance ClassNames HsName where
+    classEq = toHsName classEq
+    classOrd = toHsName classOrd 
+    classEnum = toHsName classEnum
+    classBounded = toHsName classBounded
+    classShow = toHsName classShow
+    classRead = toHsName classRead
+    classIx = toHsName classIx 
+    classFunctor = toHsName classFunctor 
+    classMonad = toHsName classMonad 
+    classNum = toHsName classNum 
+    classReal = toHsName classReal 
+    classIntegral = toHsName classIntegral 
+    classFractional = toHsName classFractional 
+    classFloating = toHsName classFloating 
+    classRealFrac = toHsName classRealFrac 
+    classRealFloat = toHsName classRealFloat 
+
+
+
+toHsQualType (HsUnQualType t) = HsQualType [] t
+toHsQualType qt = qt
+
+addClassToHierarchy :: Monad m =>  KindEnv -> HsDecl -> ClassHierarchy -> m ClassHierarchy
+addClassToHierarchy  kt (HsClassDecl _ t decls) (ClassHierarchy h) |   (HsQualType cntxt (HsTyApp (HsTyCon className) (HsTyVar argName)))  <- toHsQualType t = let 
+   qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)
+   newClassContext = [(className, argName)] 
+   in return $ ClassHierarchy $ Map.insertWith combineClassRecords  className ClassRecord { className = className, classSupers = map fst cntxt, classInsts = [], classDerives = [], classAssumps = qualifiedMethodAssumps } h  
+    
+
+addClassToHierarchy  _ _ ch = return ch
+
+--addClassToHierarchy mod kt (HsClassDecl _sloc (HsUnQualType (HsTyApp (HsTyCon className) (HsTyVar argName))) decls) h
+--   = addToEnv (className, ([], [], qualifiedMethodAssumps)) h
+--   where
+--   qualifiedMethodAssumps
+--      = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isSigDecl decls) 
+--   newClassContext
+--      = [(className, argName)] 
+--qualifyMethod cntxt (HsTypeSig sloc names (HsUnQualType t))
+--   = HsTypeSig sloc names (HsQualType cntxt t)
+
+qualifyMethod :: HsContext -> (HsDecl) -> (HsDecl)
+qualifyMethod [(c,n)] (HsTypeSig sloc names (HsQualType oc t)) 
+    = HsTypeSig sloc names (HsQualType ((c,n'):oc) t) where
+        --n' = fromJust $ applyTU (once_tdTU $ adhocTU failTU f) t  
+        --f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig n = return n'
+        --f (HsTyVar n')  = return n'
+        --f _ = mzero
+        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,runIdentity $ 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: " ++ (concatInter ", " (map showInst insts))
+        putStrLn ""
+        
+        
+
+printClassHierarchy :: ClassHierarchy -> IO ()
+printClassHierarchy (ClassHierarchy h)
+   = mapM_ printClassDetails $  Map.toList h
+   where
+   printClassDetails :: (HsName, ClassRecord) -> IO ()
+   printClassDetails (cname, (ClassRecord { classSupers = supers, classInsts = insts, classAssumps = methodAssumps}))
+      = do
+            putStrLn "..........."
+            putStrLn $ "class: " ++ show cname
+            putStr $ "super classes:"
+            case supers of
+               [] -> putStrLn $ " none"
+               _  -> putStrLn $ " " ++ (showListAndSep id " " (map show supers))
+            putStr $ "instances:"
+            case insts of
+               [] -> putStrLn $ " none"
+               _  -> putStrLn $ "\n" ++ (showListAndSepInWidth showInst 80 ", " insts)
+            putStr $ "method signatures:"
+            case methodAssumps of
+            
+               [] -> putStrLn $ " none"
+               _  -> putStrLn $ "\n" ++ 
+                        (unlines $ map pretty methodAssumps)
+            
+         
+            putStr "\n"
+
+{-
+genClassHierarchy :: [(HsDecl)] -> ClassHierarchy 
+genClassHierarchy classes 
+   = foldl (flip addClassToHierarchy) stdClassHierarchy classes 
+   where
+   -- stdClassHierarchy = classListToHierarchy stdClasses
+   stdClassHierarchy = listToFM preludeClasses 
+-}
+
+--------------------------------------------------------------------------------
+
+addInstancesToHierarchy :: Monad m => KindEnv -> ClassHierarchy -> [HsDecl] -> m ClassHierarchy
+addInstancesToHierarchy kt ch decls = do
+    insts <- mapM (hsInstDeclToInst kt) decls
+    return $ foldl addOneInstanceToHierarchy ch (concat insts)
+   --where 
+   --instances = concatMap (hsInstDeclToInst kt) decls
+
+
+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 -> (Bool,Inst) -> ClassHierarchy
+addOneInstanceToHierarchy ch (x,inst@(cntxt :=> IsIn className _)) = modifyClassRecord f className ch where
+    f c 
+        | x = c { classInsts = inst:classInsts c, classDerives = inst:classDerives c }
+        | otherwise = c { classInsts = inst:classInsts c  }
+
+{-
+   = newHierarchy
+   where
+   newHierarchy
+      -- check to make sure the class exists
+      -- = case lookupFM ch className of
+      = case lookupEnv className ch of
+           Nothing
+              -> error $ "addInstanceToHierarchy: attempt to add instance decl: " ++ showInst inst ++
+                         ", to non-existent class: " ++ show className
+           Just _ -> addToCombFM nodeCombiner className newElement ch
+   newElement = ([], [inst], [])
+   nodeCombiner :: ([HsName], [Inst], [Assump]) -> ([HsName], [Inst], [Assump]) -> ([HsName], [Inst], [Assump])
+   nodeCombiner (_, [newInst], _) (supers, oldInsts, oldMethodSigs) = (supers, newInst:oldInsts, oldMethodSigs)
+
+
+from section 4.3.2 of the Haskell 98 report
+
+instance decls look like:
+   instance cx' => C (T u1 ... uk) where { d }
+
+where u_i are simple variables and are distinct
+
+XXX
+currently hsInstDeclToInst does not check whether the context of
+an instance declaration is legal, for example it allows:
+
+instance (Eq a, Functor a) => Eq (Tree a) where ...
+ the kind of Functor, and Eq are different (the Functor is wrong here)
+
+-}
+
+hsInstDeclToInst :: Monad m => KindEnv -> (HsDecl) -> m [(Bool,Inst)]
+hsInstDeclToInst kt (HsInstDecl _sloc qType _decls)
+   | classKind == argTypeKind
+        = return [(False,cntxt :=> IsIn className convertedArgType)]
+   | otherwise
+        = failSl _sloc $ "hsInstDeclToInst: kind error, attempt to make\n" ++
+                  show argType ++ " (with kind " ++
+                  show argTypeKind ++ ")\n" ++
+                  "an instance of class " ++ show className ++
+                  " (with kind " ++ show classKind ++ ")"
+   where
+   (cntxt, classType, argType) 
+      = case toHsQualType qType of
+           HsQualType context (HsTyApp cType@(HsTyCon _) aType)
+              -> (map (aHsAsstToPred kt) context, cType, aType)
+   {- 
+      Note:
+      kind (Either) = *->*->*
+      kind (Either a) = *->*
+      kind (Either a b) = *
+
+      the kind of the argument type (argTypeKind) is the remaining
+      kind after droping the kinds of the supplied arguments from
+      the kind of the type constructor
+   -}
+   argTypeKind :: Kind
+   convertedArgType :: Type
+   (argTypeKind, convertedArgType)
+      = case argType of
+           HsTyTuple args -> (Star, tTTuple $ map toType $ zip args $ repeat Star)
+           _anythingElse 
+              -> let tyConName = nameOfTyCon tyCon 
+                     numArgs = (length flatType) - 1
+                     flatType = flattenLeftTypeApplication argType
+                     flatTyConKind = unfoldKind tyConKind
+                     tyConKind = kindOf tyConName kt
+                     tyCon = head flatType
+                     typeKindPairs = (tyCon, tyConKind) : (zip (tail flatType) flatTyConKind)
+                     in (foldr1 Kfun $ drop numArgs flatTyConKind,
+                         convType typeKindPairs)
+   className = nameOfTyCon classType
+   [classKind] = kindOfClass className kt
+
+-- derive statements
+hsInstDeclToInst kt (HsDataDecl _sloc cntxt tyConName argNames _condecls derives@(_:_)) 
+   = return $ map ((,) True) newInstances
+   where
+   tyConKind = kindOf 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 (aHsAsstToPred 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 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 (aHsAsstToPred kt) cntxt
+   --newInstances = makeDeriveInstances newContext convertedType derives 
+   newInstances = mempty
+
+hsInstDeclToInst _ _ = return []
+
+-- 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 n k
+toType (HsTyVar n, k) = TVar $ tyvar n k
+toType (HsTyFun x y, Star) = TArrow (toType (x,Star)) (toType (y,Star))
+toType x = error $ "toType: " ++ show x
+
+{-
+makeDeriveInstances :: [Pred] -> Type -> [Class] -> [Inst]
+makeDeriveInstances context t [] = []
+makeDeriveInstances context t (c:cs)
+   | c `elem` deriveableClasses
+        = (context :=> IsIn c t) : makeDeriveInstances context t cs
+   | otherwise
+        = error $ "makeDeriveInstances: attempt to make type " ++ pretty t ++ 
+                  "\nan instance of a non-deriveable class " ++ c
+-}
+
+-- as defined by section 4.3.3 of the haskell report
+{-
+deriveableClasses :: [Class]
+deriveableClasses = ["Eq", "Ord", "Enum", "Bounded", "Show", "Read"]
+-}
+
+{-
+
+   converts leftmost type applications into lists
+
+   (((TC v1) v2) v3) => [TC, v1, v2, v3]
+
+-}
+
+ 
+--------------------------------------------------------------------------------
+
+-- code for making instance methods into top level decls
+-- by adding a (instantiated) type signature from the corresponding class
+-- decl
+--   className 
+--      = case qualType of
+--           HsQualType _cntxt (HsTyApp (HsTyCon className) _argType) -> className
+--           HsUnQualType (HsTyApp (HsTyCon className) _argType) -> className 
+
+-- {-
+
+
+    
+
+makeDerivation kt ch name args cs ds = ([],[])
+makeDerivation kt ch name args cs ds = ([],concatMap f ds) where
+    f n 
+        | n == classEnum = [cia  (hsValName ("Prelude","toEnum")), cia $ hsValName ("Prelude","fromEnum")]      
+        | n == classBounded = [cia  (hsValName ("Prelude","minBound")), cia $ hsValName ("Prelude","maxBound")]      
+        | otherwise = error "cannot derive"
+        where
+        cia = createInstanceAssump kt methodSigs [] n arg
+        methodSigs = asksClassRecord ch n classAssumps 
+    arg = foldr HsTyApp (HsTyCon name) (map HsTyVar args)
+    
+
+
+instanceToTopDecls :: KindEnv -> ClassHierarchy -> HsDecl -> (([HsDecl],[Assump]))
+instanceToTopDecls kt (ClassHierarchy classHierarchy) (HsInstDecl _ qualType methods)
+   = unzip $ map (methodToTopDecls kt methodSigs qualType) $ methodGroups where
+   HsQualType _ (HsTyApp (HsTyCon className) _) = qualType
+   methodGroups = groupEquations methods
+   methodSigs = case Map.lookup className classHierarchy  of
+           Nothing -> error $ "instanceToTopDecls: could not find class " ++ fromHsName className ++ "in class hierarchy"
+           Just sigs -> classAssumps sigs
+instanceToTopDecls kt classHierarchy decl@HsDataDecl {} = 
+     (makeDerivation kt classHierarchy (hsDeclName decl) (hsDeclArgs decl) (hsDeclCons decl)) (hsDeclDerives decl) 
+instanceToTopDecls kt classHierarchy decl@HsNewTypeDecl {} = 
+    (makeDerivation kt classHierarchy (hsDeclName decl) (hsDeclArgs decl) [(hsDeclCon decl)]) (hsDeclDerives decl) 
+        
+        
+instanceToTopDecls _ _ _ = mempty
+
+
+
+getHsTypeCons (HsTyCon n) = n
+getHsTypeCons (HsTyApp a _) = getHsTypeCons a
+getHsTypeCons (HsTyFun {}) = Qual (Module "Prelude") $ HsIdent "->"
+getHsTypeCons (HsTyTuple xs) = Qual (Module "Prelude") $ HsIdent ("(" ++ replicate (length xs - 1) ',' ++ ")")
+getHsTypeCons x = error $ "getHsTypeCons: " ++ show x
+
+
+instanceName n t = Qual (Module "Instance@") $ HsIdent ('i':show n ++ "." ++ show t)
+defaultInstanceName n = Qual (Module "Instance@") $ HsIdent ('i':show n ++ ".default")
+
+createInstanceAssump kt methodSigs cntxt className argType methodName
+   = newMethodName :>: instantiatedSig where
+    newMethodName = instanceName methodName (getHsTypeCons argType)
+    [sigFromClass] = [ s | n :>: s <- methodSigs, n == methodName]
+    instantiatedSig = newMethodSig' kt methodName cntxt sigFromClass argType
+
+methodToTopDecls :: KindEnv -> [Assump] -> HsQualType -> (HsName, HsDecl) -> (HsDecl,Assump)
+
+methodToTopDecls kt methodSigs (HsQualType cntxt classApp) (methodName, methodDecls)
+   = (renamedMethodDecls,newMethodName :>: instantiatedSig) where
+    (HsTyApp (HsTyCon className) argType) = classApp
+    newMethodName = instanceName methodName (getHsTypeCons argType)
+    sigFromClass = case [ s | n :>: s <- methodSigs, n == methodName] of
+        [x] -> x
+        _ -> error $ "sigFromClass: " ++ show methodSigs ++ " " ++ show  methodName
+    --instantiatedSig = newMethodSig' (kiHsQualTypePredPred kt qt) cntxt sigFromClass argType
+    instantiatedSig = newMethodSig' kt methodName cntxt sigFromClass argType
+     --  = newMethodSig cntxt newMethodName sigFromClass argType
+    renamedMethodDecls
+       = renameOneDecl newMethodName methodDecls
+
+renameOneDecl :: HsName -> 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 newName) rhs wheres
+
+renameOneMatch :: HsName -> HsMatch -> HsMatch
+renameOneMatch newName (HsMatch sloc oldName pats rhs wheres)
+   = HsMatch sloc newName pats rhs wheres
+
+
+   
+newMethodSig' :: KindEnv -> HsName -> HsContext -> Scheme -> HsType -> Scheme
+newMethodSig' kt methodName newCntxt qt' instanceType  = newQualType where     
+   ((IsIn _ classArg:restContext) :=> t) = unQuantify 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 (getHsTypeCons instanceType)) ++ "@@"
+
+   --newQualType = runIdentity $ (applyTP $ full_tdTP (adhocTP idTP at)) $ quantify (tv qt) qt 
+   --at (Tyvar n k) = return $ Tyvar (hsNameIdent_u (hsIdentString_u (++ foo)) n) k
+   --qt = (map (aHsAsstToPred kt) newCntxt ++ restContext) :=> (runIdentity $ applyTP (full_tdTP $ adhocTP idTP ct) t) 
+   --ct n | n == classArg = return $ aHsTypeToType kt instanceType
+   --ct n = return n
+   newQualType = everywhere (mkT at) $ quantify (tv qt) qt 
+   at (Tyvar _ n k) =  tyvar (hsNameIdent_u (hsIdentString_u (++ foo)) n) k
+   qt = (map (aHsAsstToPred kt) newCntxt ++ restContext) :=> (everywhere (mkT ct) t) 
+   ct n | n == classArg =  aHsTypeToType kt instanceType
+   ct n =  n
+
+{-
+newMethodSig :: HsContext -> HsName -> HsDecl -> HsType -> HsDecl
+newMethodSig newCntxt newName (HsTypeSig _sloc methodName (HsQualType cntxt t)) instanceType
+   = HsTypeSig bogusASrcLoc [newName] newQualType 
+   where
+   -- 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
+   newT = oneTypeReplace (HsTyVar classArg, instanceType) t 
+   newQualType 
+      = let finalCntxt = newCntxt++restContxt 
+           in case finalCntxt of
+                 []    -> HsUnQualType newT
+                 (_:_) -> HsQualType finalCntxt newT 
+-- -}
+  
+-- collect assumptions of all class methods 
+
+classMethodAssumps :: ClassHierarchy -> [Assump]
+classMethodAssumps hierarchy = concatMap classAssumps $ classRecords hierarchy
+
+--------------------------------------------------------------------------------
+
+splitReduce :: Monad m => ClassHierarchy -> [Tyvar] -> [Tyvar] -> [Pred] -> m ([Pred], [Pred], [(Tyvar,Type)])
+
+splitReduce h fs gs ps = do
+    (ds, rs) <- split h fs ps
+    (rs',sub) <- genDefaults h (fs++gs) rs
+    return (ds,rs',sub)
+
+-- context reduction
+-- This is the 'split' from THIH
+
+
+reduce :: Monad 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')
+
+--------------------------------------------------------------------------------
+
+-- context splitting
+-- This is equivalant to a 'reduce' then a 'partition' in THIH
+
+split       :: Monad m => ClassHierarchy -> [Tyvar] -> [Pred] -> m ([Pred], [Pred])
+split h fs ps  = do
+    ps' <- (toHnfs h ps)
+    return $ partition (all (`elem` fs) . tv) $ 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: "  ++ render (pprint  p)
+         Just ps -> toHnfs h ps
+
+inHnf       :: Pred -> Bool
+inHnf (IsIn c t) = hnf t
+ where hnf (TVar v)  = True
+       hnf (TCon tc) = False
+       hnf (TAp t _) = hnf t
+       hnf (TArrow _t1 _t2) = False 
+--       hnf (TTuple _args) = False 
+
+--simplify          :: ClassHierarchy -> [Pred] -> [Pred] -> [Pred]
+--simplify h rs []     = rs
+--simplify h rs (p:ps) = simplify h (p:(rs\\qs)) (ps\\qs)
+-- where qs       = bySuper h p
+--       rs \\ qs = [ r | r<-rs, r `notElem` qs ]
+
+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
+--     where qs       = bySuper h p
+--           rs \\ qs = [ r | r<-rs, r `notElem` qs ]
+-----------------------------------------------------------------------------
+
+-- defaulting ambiguous constraints
+
+
+-- ambiguities from THIH + call to candidates
+ambig :: ClassHierarchy -> [Tyvar] -> [Pred] -> [(Tyvar,[Pred],[Type])]
+
+ambig h vs ps
+  = [ (v, qs, defs h v qs) |
+         v <- tv ps \\ vs,
+         let qs = [ p | p<-ps, v `elem` tv p ] ]
+
+-- 'candidates' from THIH
+defs     :: ClassHierarchy -> Tyvar -> [Pred] -> [Type]
+defs h v qs = [ t | all ((TVar v)==) ts,
+                  all (`elem` stdClasses) cs, -- XXX needs fixing
+                  any (`elem` numClasses) cs, -- XXX needs fixing
+                  -- False, -- XXX 
+                  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 ]
+
+withDefaults     :: Monad m => ClassHierarchy ->  [Tyvar] -> [Pred] -> m [(Tyvar, [Pred], Type)]
+withDefaults h vs ps 
+  | any null tss = fail $ "ambiguity: " ++ (render $ pprint 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 ->  [Tyvar] -> [Pred] -> m ([Pred],[(Tyvar,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)
+
+useDefaults     :: Monad m => ClassHierarchy -> [Tyvar] -> [Pred] -> m [Pred]
+useDefaults h vs ps
+  | any null tss = fail $ "ambiguity: " ++ (render $ pprint ps) ++  show ps  
+  | otherwise = fail $ "Zambiguity: " ++ (render $ pprint ps) ++  show (ps,ps',ams)  
+  | otherwise    = return $ ps \\ ps'
+    where ams = ambig h vs ps
+          tss = [ ts | (v,qs,ts) <- ams ]
+          ps' = [ p | (v,qs,ts) <- ams, p<-qs ]
+
+topDefaults     :: Monad m => ClassHierarchy -> [Pred] -> m Subst
+topDefaults h ps
+  | any null tss = fail $ "topDefaults: ambiguity " ++ (render $ pprint ps) 
+  | otherwise    = return $ listToFM (zip vs (map head tss))
+    where ams = ambig h [] ps
+          tss = [ ts | (v,qs,ts) <- ams ]
+          vs  = [ v  | (Tyvar v _ _,qs,ts) <- ams ]
+
+defaults    :: [Type]
+defaults     = map (\name -> TCon (Tycon (Qual (Module "Prelude") (HsIdent name)) Star))
+                   ["Integer", "Double"]
+
+
+
+failSl sl m = fail $ show sl ++ ": " ++ m
+
+classHierarchyFromRecords rs =  ClassHierarchy $ Map.fromListWith combineClassRecords [  (className x,x)| x <- rs ]
+
+-- I love tying el knot.
+makeClassHierarchy :: Monad m => ClassHierarchy -> KindEnv -> [HsDecl] -> m ClassHierarchy
+makeClassHierarchy (ClassHierarchy ch) kt ds = return (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 = [(className, argName)] 
+            tell [ClassRecord { className = className, classSrcLoc = sl, classSupers = map fst cntxt, classInsts = [], classDerives = [], classAssumps = qualifiedMethodAssumps }] 
+        | otherwise = failSl sl "Invalid Class declaration." 
+        where
+        HsQualType cntxt tbody = toHsQualType t
+    f decl = hsInstDeclToInst kt decl >>= \insts -> do
+        crs <- flip mapM [ (cn,i) | (_,i@(_ :=> 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 ()
+    {-
+
+addClassToHierarchy :: Monad m =>  KindEnv -> HsDecl -> ClassHierarchy -> m ClassHierarchy
+addClassToHierarchy  kt (HsClassDecl _ t decls) (ClassHierarchy h) |   (HsQualType cntxt (HsTyApp (HsTyCon className) (HsTyVar argName)))  <- toHsQualType t = let 
+   qualifiedMethodAssumps = concatMap (aHsTypeSigToAssumps kt . qualifyMethod newClassContext) (filter isHsTypeSig decls)
+   newClassContext = [(className, argName)] 
+   in return $ ClassHierarchy $ Map.insertWith combineClassRecords  className ClassRecord { className = className, classSupers = map fst cntxt, classInsts = [], classDerives = [], classAssumps = qualifiedMethodAssumps } h  
+    
+
+addClassToHierarchy  _ _ ch = return ch
+
+addInstancesToHierarchy :: Monad m => KindEnv -> ClassHierarchy -> [HsDecl] -> m ClassHierarchy
+addInstancesToHierarchy kt ch decls = do
+    insts <- mapM (hsInstDeclToInst kt) decls
+    return $ foldl addOneInstanceToHierarchy ch (concat insts)
+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 :: ClasHierarchy -> (Bool,Inst) -> ClassHierarchy
+addOneInstanceToHierarchy ch (x,inst@(cntxt :=> IsIn className _)) = modifyClassRecord f className ch where
+    f c 
+        | x = c { classInsts = inst:classInsts c, classDerives = inst:classDerives c }
+        | otherwise = c { classInsts = inst:classInsts c  }
+
+
+-}
addfile ./FrontEnd/DataConsAssump.hs
hunk ./FrontEnd/DataConsAssump.hs 1
+{-------------------------------------------------------------------------------
+
+        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 DataConsAssump (dataConsEnv) where
+
+
+import HsSyn  
+import Representation     
+import Type                     (assumpToPair, makeAssump, Types (..), quantify)
+import TypeUtils                (aHsTypeToType)
+import KindInfer 
+import FrontEnd.Env              
+
+--------------------------------------------------------------------------------
+
+dataConsEnv :: Module -> KindEnv -> [HsDecl] -> Env Scheme 
+dataConsEnv modName kt decls 
+   = joinListEnvs $ 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) -> Env Scheme 
+dataDeclEnv modName kt (HsDataDecl _sloc context typeName args condecls _)
+   = joinListEnvs $ map (conDeclType modName kt preds resultType) $ condecls 
+   where
+   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 n k)
+   preds = hsContextToPreds kt context
+
+dataDeclEnv modName kt (HsNewTypeDecl _sloc context typeName args condecl _)
+   = conDeclType modName kt preds resultType condecl
+   where
+   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 n k)
+   preds = hsContextToPreds kt context
+
+dataDeclEnv _modName _kt _anyOtherDecl 
+   = emptyEnv
+
+
+hsContextToPreds :: KindEnv -> HsContext -> [Pred]
+hsContextToPreds kt assts = map (hsAsstToPred kt) assts
+
+conDeclType :: Module -> KindEnv -> [Pred] -> Type -> HsConDecl -> Env Scheme 
+conDeclType modName kt preds tResult (HsConDecl _sloc conName bangTypes)
+   = unitEnv $ assumpToPair $ makeAssump conName $ quantify (tv qualConType) qualConType
+   where
+   conType = foldr fn tResult (map (bangTypeToType kt) bangTypes)
+   qualConType = preds :=> conType
+conDeclType modName kt preds tResult rd@(HsRecDecl _sloc conName _)
+   = unitEnv $ assumpToPair $ makeAssump conName $ quantify (tv qualConType) qualConType
+   where
+   conType = foldr fn tResult (map (bangTypeToType kt) (hsConDeclArgs rd))
+   qualConType = preds :=> conType
+
+bangTypeToType :: KindEnv -> HsBangType -> Type
+bangTypeToType kt (HsBangedTy t) = aHsTypeToType kt t 
+bangTypeToType kt (HsUnBangedTy t) = aHsTypeToType kt t
+
addfile ./FrontEnd/DeclsDepends.hs
hunk ./FrontEnd/DeclsDepends.hs 1
+{-------------------------------------------------------------------------------
+
+        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 DeclsDepends (getDeclDeps, debugDeclBindGroups) where
+
+import HsSyn 
+import DependAnalysis           (debugBindGroups)
+import Utils                    (getDeclName, fromHsName)
+import FrontEnd.Rename          (unRename)
+
+--------------------------------------------------------------------------------
+
+-- for printing out decl bindgroups
+
+debugDeclBindGroups :: [[HsDecl]] -> String
+debugDeclBindGroups groups 
+   = debugBindGroups groups (fromHsName . unRename . getDeclName)
+                            getDeclName
+                            getDeclDeps  
+
+-- HsDecl getDeps function 
+
+
+getDeclDeps :: HsDecl -> [HsName]
+
+getDeclDeps (HsPatBind _pat _ rhs wheres) 
+   = getRhsDeps rhs ++ foldr (++) [] (map getLocalDeclDeps wheres)
+
+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 _ = []
+
+-- 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 (HsVar name) 
+   = [name] 
+
+getExpDeps (HsCon _)
+   = []
+
+getExpDeps (HsLit _)
+   = []
+
+getExpDeps (HsInfixApp e1 e2 e3)
+   = getExpDeps e1 ++
+     getExpDeps e2 ++
+     getExpDeps e3 
+
+getExpDeps (HsApp e1 e2) 
+   = getExpDeps e1 ++ getExpDeps e2 
+
+getExpDeps (HsNegApp e) 
+   = getExpDeps e 
+
+getExpDeps (HsLambda _ _ e) 
+   = getExpDeps e 
+
+getExpDeps (HsLet decls e)
+   = foldr (++) [] (map getLocalDeclDeps decls) ++
+     getExpDeps e 
+
+getExpDeps (HsIf e1 e2 e3) 
+   = getExpDeps e1 ++
+     getExpDeps e2 ++
+     getExpDeps e3 
+
+getExpDeps (HsCase e alts)
+   = getExpDeps e ++
+     foldr (++) [] (map getAltDeps alts)
+
+getExpDeps (HsDo stmts)
+   = foldr (++) [] (map getStmtDeps stmts)
+
+getExpDeps (HsTuple exps) 
+   = foldr (++) [] (map getExpDeps exps)
+
+getExpDeps (HsList exps) 
+   = foldr (++) [] (map getExpDeps exps)
+
+getExpDeps (HsParen e)
+   = getExpDeps e
+
+getExpDeps (HsLeftSection e1 e2)
+   = getExpDeps e1 ++
+     getExpDeps e2
+
+getExpDeps (HsRightSection e1 e2)
+   = getExpDeps e1 ++
+     getExpDeps e2
+
+getExpDeps (HsEnumFrom e)
+   = getExpDeps e
+
+getExpDeps (HsEnumFromTo e1 e2)
+   = getExpDeps e1 ++
+     getExpDeps e2
+
+getExpDeps (HsEnumFromThen e1 e2)
+   = getExpDeps e1 ++
+     getExpDeps e2
+
+getExpDeps (HsEnumFromThenTo e1 e2 e3)
+   = getExpDeps e1 ++
+     getExpDeps e2 ++
+     getExpDeps e3
+getExpDeps (HsListComp e stmts) = getExpDeps e ++ foldr (++) [] (map getStmtDeps stmts)
+getExpDeps (HsExpTypeSig _sloc e _qualtype) = getExpDeps e
+getExpDeps (HsAsPat _name e) = getExpDeps e
+getExpDeps (HsWildCard _) = []
+getExpDeps (HsIrrPat e) = getExpDeps e
+getExpDeps (HsRecConstr _ fs) = concat [ getExpDeps e | HsFieldUpdate _ e <- fs ]
+getExpDeps (HsRecUpdate e fs) =  concat $ getExpDeps e:[ getExpDeps e | HsFieldUpdate _ e <- fs ]
+
+getExpDeps e = error $ "getExpDeps: " ++ show e
+
+getAltDeps :: HsAlt -> [HsName]
+
+getAltDeps (HsAlt _sloc _pat guardedAlts wheres)
+   = getGuardedAltsDeps guardedAlts ++
+     foldr (++) [] (map getLocalDeclDeps wheres) 
+
+getGuardedAltsDeps :: HsGuardedAlts -> [HsName]
+getGuardedAltsDeps (HsUnGuardedAlt e)
+   = getExpDeps e
+
+getGuardedAltsDeps (HsGuardedAlts gAlts)
+   = foldr (++) [] (map getGAltsDeps gAlts)
+
+getGAltsDeps :: HsGuardedAlt -> [HsName]
+getGAltsDeps (HsGuardedAlt _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)
addfile ./FrontEnd/DependAnalysis.hs
hunk ./FrontEnd/DependAnalysis.hs 1
+{-------------------------------------------------------------------------------
+
+        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 DependAnalysis (getBindGroups, showBindGroups, 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 ++ "]"
+
+--------------------------------------------------------------------------------
addfile ./FrontEnd/Deriving.hs
hunk ./FrontEnd/Deriving.hs 1
+module FrontEnd.Deriving(deriveInstances) where
+
+import HsSyn
+import Class
+import VConsts
+import Name
+
+
+vars = [ UnQual (HsIdent ('d':show v ++ "_derive@") ) |  v <- [1::Int ..]]
+
+deriveInstances :: Monad m => SrcLoc -> HsName -> [HsName] -> [HsConDecl] -> [HsName] -> m [HsDecl]
+deriveInstances sloc name args cons ds = return []
+deriveInstances sloc name args cons ds = return $ concatMap f ds where
+    f n 
+        | n == hsUnqualValName "Bounded" = [inst n (mkBounded cons)]
+        | n == hsUnqualValName "Enum" = [inst n (mkEnum cons)] 
+        | otherwise = error $ "unknown deriving: " ++ show n 
+    inst n ds = HsInstDecl sloc (HsQualType [] (HsTyApp (HsTyCon n) tipe))  ds  
+    tipe = foldr HsTyApp (HsTyCon name) (map HsTyVar args)
+    patBind n v = HsPatBind sloc (HsPVar n) (HsUnGuardedRhs v) []
+    match n ps v = HsMatch sloc n ps (HsUnGuardedRhs v) []
+    mkBounded cs = [patBind (hsValName ("@Prelude","minBound")) (HsCon $ hsConDeclName (head cs)),  patBind (hsValName ("Prelude","maxBound")) (HsCon $ hsConDeclName (last cs))]
+    mkEnum cs = [HsFunBind (map f (zip cs [0..])),  HsFunBind $ (map g (zip cs [0..])) ++ [err]] where 
+        f (c,n) = match (hsValName ("@Prelude","fromEnum")) [HsPApp (hsConDeclName c) []] (HsLit $ HsInt ( n))
+        g (c,n) =  match (hsValName ("@Prelude","toEnum")) [HsPLit (HsInt ( n))] (HsCon (hsConDeclName c))
+        err = match (hsValName ("@Prelude","toEnum"))  [HsPWildCard] (HsApp (HsVar (hsValName ("@Prelude","error"))) (HsLit $ HsString $ "toEnum: " ++ show name))
+
+{-
+data Statement = DataStmt | NewTypeStmt deriving (Eq,Show)
+data Data = D {	name :: String,		-- type name
+                constraints :: [(Class,Var)], 
+                vars :: [Var],		-- Parameters
+                body :: [Body],
+                derives :: [Class],		-- derived classes
+                statement :: Statement}
+		deriving (Eq,Show) 
+data Body = Body { 
+    constructor :: String,
+    labels :: [String],
+    types :: [HsBangType]
+    } deriving (Eq,Show) 
+
+
+toData :: HsName -> [HsName] -> [HsConDecl] -> [HsName] -> Data 
+toData name args cons derives = ans where
+    f c = Body { constructor = show $ hsConDeclName c, types = hsConDeclArgs c, labels = lb c } 
+    lb HsConDecl {} = []
+    lb r = concat [map show xs | (xs,_) <- hsConDeclRecArg r ]
+    ans = D { statement = DataStmt, vars = map show args, constraints = [], name = name,  derives = map show derives, body = map f cons }
+                                                         
+{-
+type Name = String
+type Var = String
+type Class = String
+type Constructor = String
+-}
+
+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 ..]
+		, c' <- zip (body d) [1 ..]]
+   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", "y"]
+		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
+
+
+----------------------------------------------------------------------
+
+type IFunction= Body -> HsMatch
+
+hsName x y = Qual (Module x) (HsIdent y)
+hsUName x = UnQual (HsIdent x)
+
+instanceSkeleton _ fs d = ans where
+    ans = HsFunBind $ concat [ map x (body d) ++ y | (x,y) <- fs ] 
+
+showfn = instanceSkeleton "Show" [(makeShow,mempty)] 
+
+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 = hsUName "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]
+        showString s = HsApp (HsVar $ hsName ("Prelude.Text","showString")) (HsLit (HsString 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 ..])
+	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 ..])
+	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
+-}
addfile ./FrontEnd/Desugar.hs
hunk ./FrontEnd/Desugar.hs 1
+{-------------------------------------------------------------------------------
+
+        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) where
+
+import Control.Monad.State
+import FrontEnd.Deriving
+import HsSyn
+import VConsts
+import Name
+import GenUtil
+
+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))
+
+--newtype PatSM a = PatSM (PatState -> (a, PatState))  -- The monadic type
+
+type PatSM = State PatState
+
+--instance Monad PatSM where
+--  -- defines state propagation
+--  PatSM c1 >>= fc2         =  PatSM (\s0 -> let (r,s1) = c1 s0
+--                                                PatSM c2 = fc2 r in
+--                                                c2 s1)
+--  return k                  =  PatSM (\s -> (k,s))
+--
+-- -- extracts the state from the monad
+--readPatSM                  :: PatSM PatState 
+--readPatSM                  =  PatSM (\s -> (s,s))
+--
+-- -- updates the state of the monad
+--updatePatSM                :: (PatState -> PatState) -> PatSM ()  -- alters the state
+--updatePatSM f              =  PatSM (\s -> ((), f s))
+--
+---- run a computation in the PatSM monad
+--runPatSM                   :: PatState -> PatSM a -> (a, PatState)
+--runPatSM s0 (PatSM c)     =  c s0
+
+{------------------------------------------------------------------------------}
+
+readPatSM = get
+updatePatSM = modify
+runPatSM = flip runState
+
+
+-- a new (unique) name introduced in pattern selector functions
+newPatVarName :: HsName
+newPatVarName = hsUnqualValName "patvar@0"
+
+-- a new (unique) name introduced in expressions 
+newVarName :: HsName
+newVarName = hsUnqualValName "var@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
+    
+--desugarTidyModule :: [HsDecl] -> TidyModule -> TidyModule
+--desugarTidyModule importSyns tidy
+--   = newTidy
+--   where
+--   (newTidy, _) = runPatSM (0::Int, synonyms) $ desugarTidyModuleM tidy 
+--   synonyms = tidyTyDecls tidy ++ importSyns
+--
+--desugarTidyModuleM :: TidyModule -> PatSM TidyModule
+--desugarTidyModuleM tidy
+--   = do let oldTyDecls    = tidyTyDecls tidy
+--            oldDataDecls  = tidyDataDecls tidy
+--            oldInFixDecls = tidyInFixDecls tidy
+--            oldNewTyDecls = tidyNewTyDecls tidy
+--            oldClassDecls = tidyClassDecls tidy
+--            oldInstDecls  = tidyInstDecls tidy
+--            oldDefs       = tidyDefDecls tidy
+--            oldTySigs     = tidyTySigs tidy
+--            oldFunBinds   = tidyFunBinds tidy
+--            oldPatBinds   = tidyPatBinds tidy
+--        newTyDecls    <- mapM desugarDecl oldTyDecls 
+--        newDataDecls  <- mapM desugarDecl oldDataDecls 
+--        newInFixDecls <- mapM desugarDecl oldInFixDecls 
+--        newNewTyDecls <- mapM desugarDecl oldNewTyDecls 
+--        newClassDecls <- mapM desugarDecl oldClassDecls 
+--        newInstDecls  <- mapM desugarDecl oldInstDecls 
+--        newDefs       <- mapM desugarDecl oldDefs 
+--        newTySigs     <- mapM desugarDecl oldTySigs 
+--        newFunBinds   <- mapM desugarDecl oldFunBinds 
+--        newPatBinds   <- mapM desugarDecl oldPatBinds 
+--        return tidy{tidyTyDecls    = concat newTyDecls, --[],  -- return the empty list of synonyms, we don't need them anymore
+--                    tidyDataDecls  = concat newDataDecls,
+--                    tidyInFixDecls = concat newInFixDecls,
+--                    tidyNewTyDecls = concat newNewTyDecls,
+--                    tidyClassDecls = concat newClassDecls,
+--                    tidyInstDecls  = concat newInstDecls,
+--                    tidyDefDecls   = concat newDefs,
+--                    tidyTySigs     = concat newTySigs,
+--                    tidyFunBinds   = concat newFunBinds,
+--                    tidyPatBinds   = concat newPatBinds}
+--
+
+
+desugarDecl :: HsDecl -> PatSM [HsDecl]
+desugarDecl (HsForeignDecl sl ft s n qt) = do
+    qt' <- remSynsQualType qt
+    return [HsForeignDecl sl ft s n 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)]
+        
+
+-- constructor and tuple pattern bindings must be changed
+-- XXX bjpop: what about nested parenthesised patterns that just bind
+-- variables?
+
+desugarDecl pb@(HsPatBind sloc pat rhs wheres) = do
+    rhs <- desugarRhs rhs
+    unique <- getUnique
+    let newRhsName = UnQual $ HsIdent $ "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 (HsDataDecl sloc cntxt name args condecls derives) = do
+        --newConDecls <- mapM remSynsFromCondecl condecls
+        newConDecls <- return condecls
+        ds <- deriveInstances sloc name args newConDecls derives 
+        ss <- createSelectors sloc newConDecls
+        return $ (HsDataDecl sloc cntxt name args newConDecls derives):(ds ++ ss)
+
+desugarDecl (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 $ (HsNewTypeDecl sloc cntxt name args newConDecl derives):(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 _ c 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 (HsApp (HsVar err) (HsLit (HsString (show n))))) []
+        
+    var = UnQual (HsIdent "x")
+    err = UnQual (HsIdent "error")
+
+
+
+{-
+
+remSynsFromCondecl :: HsConDecl -> PatSM HsConDecl
+remSynsFromCondecl (HsConDecl sloc name bangTypes)
+   = do
+        newBangTypes <- mapM remSynsFromBangType bangTypes
+        return (HsConDecl sloc name newBangTypes)
+remSynsFromCondecl rd@(HsRecDecl _ _ _) = return rd
+--   = error $ "remSynsFromCondecl (HsRecDecl _ _ _) not implemented"
+
+remSynsFromBangType :: HsBangType -> PatSM HsBangType
+remSynsFromBangType (HsBangedTy t) = do
+    newType <- remSynsType t
+    return (HsBangedTy newType)
+remSynsFromBangType (HsUnBangedTy t) = do
+    newType <- remSynsType t
+    return (HsUnBangedTy newType)   
+-}
+
+
+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 <- patVarNames pat] where
+    kase p =  HsCase (HsVar newPatVarName) [a1, a2 ] where
+       a1 =  HsAlt sloc p (HsUnGuardedAlt (HsVar newPatVarName)) []
+       a2 =  HsAlt sloc HsPWildCard (HsUnGuardedAlt (HsApp (HsVar (UnQual $ HsIdent "error")) (HsLit $ HsString $ show sloc ++ " failed pattern match"))) []
+
+
+--getPatSelFuns sloc pat = [(varName, HsParen (HsLambda sloc [replaceVarNamesInPat varName pat] (HsVar newPatVarName))) | varName <- patVarNames pat]
+-- returns the names of variables bound in a pattern
+-- XXX bjpop: do as patterns work properly?
+patVarNames :: HsPat -> [HsName]
+patVarNames (HsPVar name) = [name]
+patVarNames (HsPLit _) = []
+patVarNames (HsPNeg pat) = patVarNames pat
+patVarNames (HsPInfixApp pat1 conName pat2)
+   = patVarNames pat1 ++ patVarNames pat2
+patVarNames (HsPApp conName pats)
+   = concatMap patVarNames pats
+patVarNames (HsPTuple pats)
+   = concatMap patVarNames pats
+patVarNames (HsPList pats)
+   = concatMap patVarNames pats
+patVarNames (HsPParen pat)
+   = patVarNames pat
+patVarNames (HsPRec _ _) = error "patVarNames (HsPRec _ _): not implemented "
+patVarNames (HsPAsPat asName pat)
+   = asName : patVarNames pat
+patVarNames HsPWildCard = []
+patVarNames (HsPIrrPat pat)
+   = patVarNames pat 
+
+-- replaces all occurrences of a name with a new variable 
+-- and every other name with underscore
+
+replaceVarNamesInPat :: HsName -> HsPat -> HsPat
+
+replaceVarNamesInPat name1 (HsPVar name2)
+   | name1 == name2 = HsPVar $ newPatVarName
+   | otherwise = HsPWildCard
+replaceVarNamesInPat _ p@(HsPLit _) = p
+replaceVarNamesInPat name (HsPNeg pat) 
+   = HsPNeg $ replaceVarNamesInPat name pat 
+replaceVarNamesInPat name (HsPInfixApp pat1 conName pat2) 
+   = HsPInfixApp (replaceVarNamesInPat name pat1) conName (replaceVarNamesInPat name pat2)
+replaceVarNamesInPat name (HsPApp conName pats)
+   = HsPApp conName (map (replaceVarNamesInPat name) pats)
+replaceVarNamesInPat name (HsPTuple pats)
+   = HsPTuple (map (replaceVarNamesInPat name) pats)
+replaceVarNamesInPat name (HsPList pats)
+   = HsPList (map (replaceVarNamesInPat name) pats)
+replaceVarNamesInPat name (HsPParen pat)
+   = HsPParen (replaceVarNamesInPat name pat)
+replaceVarNamesInPat name (HsPRec _ _) 
+   = error  "replaceVarNamesInPat name (HsPRec _ _): not implemented"
+replaceVarNamesInPat name (HsPAsPat asName pat)
+   | name == asName = HsPAsPat newPatVarName (replaceVarNamesInPat name pat)
+   | otherwise = replaceVarNamesInPat name pat
+replaceVarNamesInPat name HsPWildCard = HsPWildCard
+replaceVarNamesInPat name (HsPIrrPat pat)
+   = HsPIrrPat $ replaceVarNamesInPat name pat 
+
+
+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 e@HsVar {} = return e
+
+desugarExp e@HsCon {} = return e 
+
+desugarExp e@HsLit {} = return e
+
+desugarExp (HsInfixApp e1 e2 e3)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        newE3 <- desugarExp e3
+        return (HsInfixApp newE1 newE2 newE3)
+
+desugarExp (HsApp e1 e2)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        return (HsApp newE1 newE2)
+
+desugarExp (HsNegApp e)
+   = do
+        newE <- desugarExp e
+        return (HsNegApp newE)
+
+desugarExp (HsLambda sloc pats e) 
+    | all isHsPVar 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 (HsUnGuardedAlt e') []
+            a2 =  HsAlt sloc HsPWildCard (HsUnGuardedAlt (HsApp (HsVar (UnQual $ HsIdent "error")) (HsLit $ HsString $ 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 = UnQual $ HsIdent $ "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 (HsIf e1 e2 e3)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        newE3 <- desugarExp e3
+        return (HsIf newE1 newE2 newE3)
+
+desugarExp (HsCase e alts)
+   = do
+        newE <- desugarExp e
+        newAlts <- mapM desugarAlt alts
+        return (HsCase newE newAlts)
+
+desugarExp (HsDo stmts)
+   = do
+        newStmts <- mapM desugarStmt stmts
+        return (doToExp newStmts)
+
+desugarExp (HsTuple exps)
+   = do
+        newExps <- mapM desugarExp exps
+        return (HsTuple newExps)
+
+desugarExp (HsList exps)   
+   = do
+        newExps <- mapM desugarExp exps
+        return (HsList newExps)
+
+desugarExp (HsParen e)
+   = do
+        newE <- desugarExp e
+        return (HsParen newE)
+
+desugarExp (HsLeftSection e1 e2)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        return (HsLeftSection newE1 newE2)
+
+desugarExp (HsRightSection e1 e2) = do
+        newE1 <- desugarExp e1                          
+        newE2 <- desugarExp e2
+        let nv = (hsUnqualValName "rsection@")
+        return (HsLambda bogusASrcLoc [HsPVar nv ] (HsApp (HsRightSection newE1 newE2) (HsVar nv)))
+
+desugarExp (HsRecConstr n fus) = do
+    fus' <- mapM desugarFU fus 
+    return $ HsRecConstr n fus'
+--   = error "desugarExp (HsRecConstr _ _): not implemented"
+
+desugarExp (HsRecUpdate e fus) = do
+    fus' <- mapM desugarFU fus 
+    e' <- desugarExp e
+    return $ HsRecUpdate e' fus'
+--   = error "desugarExp (HsRecUpdate _ _): not implemented"
+
+desugarExp (HsEnumFrom e)
+   = do
+        newE <- desugarExp e
+        return (HsEnumFrom newE)
+
+desugarExp (HsEnumFromTo e1 e2)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        return (HsEnumFromTo newE1 newE2)
+
+desugarExp (HsEnumFromThen e1 e2)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        return (HsEnumFromThen newE1 newE2)
+
+desugarExp (HsEnumFromThenTo e1 e2 e3)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        newE3 <- desugarExp e3
+        return (HsEnumFromThenTo newE1 newE2 newE3)
+
+desugarExp (HsListComp e stmts)
+   = do
+        newE <- desugarExp e
+        newStmts <- mapM desugarStmt stmts
+        return (listCompToExp newE newStmts)
+
+-- e :: t  ---> let {v :: t, v = e} in e
+
+{-
+desugarExp (HsExpTypeSig sloc e qualType)
+   = do
+        newE <- desugarExp e
+        newQualType <- remSynsQualType qualType
+        return (HsExpTypeSig sloc newE newQualType)
+-}
+
+desugarExp (HsExpTypeSig sloc e qualType)
+   = do 
+        newE <- desugarExp e
+        newQualType <- remSynsQualType qualType
+        let newTypeSig = HsTypeSig sloc [newVarName] newQualType
+        let newVarDecl = HsPatBind sloc 
+                                    (HsPVar newVarName) 
+                                    (HsUnGuardedRhs newE) []
+        return (HsLet [newTypeSig, newVarDecl] (HsVar newVarName))
+
+
+desugarExp (HsAsPat name e)
+   = do
+        newE <- desugarExp e
+        return (HsAsPat name e)
+
+desugarExp (HsWildCard x)
+   = return (HsWildCard x)
+
+desugarExp (HsIrrPat e)
+   = do
+        newE <- desugarExp e
+        return (HsIrrPat newE) 
+
+desugarFU (HsFieldUpdate n e) = do
+    e' <- desugarExp e
+    return $ HsFieldUpdate n 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 :: (HsGuardedAlts) -> PatSM (HsGuardedAlts)
+
+desugarGAlts (HsUnGuardedAlt e)
+   = do
+        newE <- desugarExp e
+        return (HsUnGuardedAlt newE)
+
+desugarGAlts (HsGuardedAlts gAlts)
+   = do
+        newGAlts <- mapM desugarGuardedAlt gAlts
+        return (HsGuardedAlts newGAlts)
+
+desugarGuardedAlt :: (HsGuardedAlt) -> PatSM (HsGuardedAlt)
+
+desugarGuardedAlt (HsGuardedAlt sloc e1 e2)
+   = do
+        newE1 <- desugarExp e1
+        newE2 <- desugarExp e2
+        return (HsGuardedAlt 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)
+        HsUnQualType t
+           -> do
+                 newT <- remSynsType t
+                 return (HsUnQualType newT)
+
+--------------------------------------------------------------------------------
+
+-- desugar the do-notation
+
+-- flatten out do notation into an expression
+-- involving ">>" and ">>="
+-- TODO -  THIS IS BROKEN
+
+
+doToExp :: [HsStmt] -> HsExp
+
+doToExp [] = error "doToExp: empty statements in do notation"
+doToExp [HsQualifier e] = e
+doToExp [gen@(HsGenerator srcLoc _pat _e)]
+   = error $ "doToExp: last expression n do notation is a generator (srcLoc):" ++ show srcLoc
+doToExp [letst@(HsLetStmt _decls)]
+   = error $ "doToExp: last expression n do notation is a let statement"
+doToExp ((HsQualifier e):ss)
+   = HsInfixApp (hsParen e) (HsVar (hsUnqualValName ">>")) (hsParen $ doToExp ss)
+doToExp ((HsGenerator _srcLoc pat@(HsPVar {}) e):ss)
+   = HsInfixApp (hsParen e) (HsVar (hsUnqualValName ">>=")) (HsLambda _srcLoc [pat] (doToExp ss))
+doToExp ((HsGenerator srcLoc pat e):ss) = HsInfixApp (hsParen e) (HsVar (hsUnqualValName ">>=")) (HsLambda srcLoc [HsPVar newPatVarName] kase)  where
+   kase = HsCase (HsVar newPatVarName) [a1, a2 ] 
+   a1 =  HsAlt srcLoc pat (HsUnGuardedAlt (doToExp ss)) []
+   a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedAlt (HsApp (HsVar (hsUnqualValName "fail")) (HsLit $ HsString $ show srcLoc ++ " failed pattern match in do"))) []
+doToExp ((HsLetStmt decls):ss)
+   = HsLet decls (doToExp ss)
+
+listCompToExp :: HsExp -> [HsStmt] -> HsExp
+listCompToExp exp ss = hsParen (f ss) where
+    f [] = HsList [exp]
+    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) = hsParen $ HsApp (HsApp (HsVar (hsUnqualValName "concatMap"))  (hsParen $ HsLambda srcLoc [HsPVar newPatVarName] kase)) e where
+        kase = HsCase (HsVar newPatVarName) [a1, a2 ] 
+        a1 =  HsAlt srcLoc pat (HsUnGuardedAlt (f ss)) []
+        a2 =  HsAlt srcLoc HsPWildCard (HsUnGuardedAlt $ HsList []) []
+    
+
+
addfile ./FrontEnd/Diagnostic.hs
hunk ./FrontEnd/Diagnostic.hs 1
+{-------------------------------------------------------------------------------
+
+        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 Diagnostic (
+       Diagnostic(..), dumpDiagnostic, withASrcLoc,
+       makeMsg,
+       locMsg,
+       locSimple,
+       simpleMsg,
+       typeError,
+       TypeError (..),
+       ) where
+
+import List  (find)
+import Maybe (isJust)
+import PPrint (PPrint, pretty)
+import HsSyn
+import Data.Monoid
+
+--------------------------------------------------------------------------------
+
+data TypeError 
+        = Unification String
+        | BogusError 
+        | Failure String
+    
+
+typeError :: TypeError -> [Diagnostic] -> a
+typeError err ds
+   = error $ "\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
+                Nothing -> "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
+
addfile ./FrontEnd/Env.hs
hunk ./FrontEnd/Env.hs 1
+{------------------------------------------------------------------------------
+
+        Copyright:              The Hatchet Team (see file Contributors)
+
+        Module:                 Env
+
+        Description:            A generic environment that supports mappings 
+                                from names to values.
+
+        Primary Authors:        Bernie Pope
+
+        Notes:                  See the file License for license information
+                                
+                                Based on FiniteMaps
+
+-------------------------------------------------------------------------------}
+
+module FrontEnd.Env (Env, 
+            emptyEnv, 
+            unitEnv, 
+            lookupEnv,
+            addToEnv,
+            joinEnv, 
+            joinListEnvs, 
+            listToEnv,
+            envToList,
+            getNamesFromEnv,
+            showEnv,
+            pprintEnv,
+            addToCombFM,
+            mapEnv,
+            zeroFM,
+            joinFM,lookupDftFM,
+            toListFM,
+            -- use these plus monoid routines when possible
+            fromList,
+            single,
+            FrontEnd.Env.find,
+            toList
+           ) where
+
+
+import Data.FiniteMap 
+import HsSyn   
+import PPrint  
+import Utils
+import Char
+import List
+import Data.Monoid
+
+
+--------------------------------------------------------------------------------
+
+{-# INLINE joinFM #-}
+{-# INLINE emptyEnv #-}
+{-# INLINE zeroFM #-}
+{-# INLINE addToCombFM #-}
+{-# INLINE lookupDftFM #-}
+zeroFM = emptyFM
+joinFM x y = plusFM y x
+toListFM  = fmToList
+addToCombFM c k v m = addToFM_C (flip c) m k v 
+lookupDftFM x = lookupWithDefaultFM x
+--addToFM x y = Data.FiniteMap.addToFM y x
+
+--instance (Show a, Show b) => Show (FiniteMap a b) where
+--    show fm = show (fmToList fm)
+
+type Env a = FiniteMap HsName a 
+
+instance Ord a => Monoid (FiniteMap a b) where
+    mempty = emptyFM
+    mappend = plusFM
+
+
+emptyEnv :: Env a
+emptyEnv = zeroFM
+
+
+single k v = unitFM k v
+
+unitEnv :: (HsName, a) -> Env a 
+unitEnv (name, val) = unitFM name val
+
+lookupEnv :: HsName -> Env a -> Maybe a 
+lookupEnv name env
+   = lookupFM env name
+
+
+find :: HsName -> Env a -> a 
+find name env = case lookupFM env name of
+    Just x -> x
+    Nothing -> error $ "Env.find: " ++ fromHsName name 
+
+
+addToEnv :: (HsName, a) -> Env a -> Env a
+addToEnv (name, val) env = addToFM env name val 
+
+-- this might be expensive!
+joinEnv :: Env a -> Env a -> Env a 
+joinEnv env1 env2 
+   = joinFM env1 env2
+
+joinListEnvs :: [Env a] -> Env a 
+joinListEnvs = foldr joinEnv emptyEnv
+
+listToEnv :: [(HsName, a)] -> Env a 
+listToEnv = foldr addToEnv emptyEnv  
+
+fromList = listToEnv
+toList = toListFM 
+
+envToList :: Env a -> [(HsName, a)]
+envToList env
+   = toListFM env 
+
+-- just get all the names out of the Env (added by Bryn)
+getNamesFromEnv :: Env a -> [HsName]
+getNamesFromEnv env = map fst (toListFM env)
+
+showEnv :: Show a => Env a -> String
+showEnv env = unlines $ map show $ toListFM env 
+
+-- pretty print the environment
+
+pprintEnv :: PPrint Doc a => Env a -> Doc
+pprintEnv env = pl global $+$ pl local_norm $+$ pl local_sys  where
+    es = fmToList env
+    (local,global) = partition (\(x,_) -> isDigit $ head (hsIdentString (hsNameIdent x)) ) es
+    (local_sys,local_norm) = partition (\(x,_) -> last (hsIdentString (hsNameIdent x)) == '@' ) local
+    pl es = vcat [((pprint a) <+> (text "::") <+> (pprint b)) | (a, b) <- es]
+
+--   = vcat [((pprint a) <+> (text "::") <+> (pprint b)) | (a, b) <- toListFM env]
+
+-- map a function over the elements of the environment
+mapEnv :: (HsName -> e -> e') -> Env e -> Env e'
+mapEnv f map = mapFM f map
+
+--------------------------------------------------------------------------------
+
+--instance (Ord a, Term a, Term b) => Term (FiniteMap a b) where
+--    explode (x::(FiniteMap a b)) = TermRep (dx, tl, rb x) where
+--        dx = toDyn x
+--        tl = map explode $ fmToList x
+--        rb (_::FiniteMap a b) l = toDyn $ listToFM ((map (\(TermRep (x,_,_)) -> fDyn x) l):: [(a,b)])
+
+
+
+--_tc_FiniteMapTc = mkTyCon "FiniteMap"
+--instance (Typeable a,Typeable b) => Typeable (FiniteMap a b) where
+--    typeOf x = mkAppTy _tc_FiniteMapTc [ typeOf (geta x),typeOf (getb x) ]
+--      where
+--        geta :: FiniteMap a b -> a
+--        geta = undefined
+--        getb :: FiniteMap a b -> b
+--        getb = undefined
+
+
addfile ./FrontEnd/Exports.hs
hunk ./FrontEnd/Exports.hs 1
+
+-- | determine export\/imports for modules via fixpoint recursion
+
+module FrontEnd.Exports(determineExports) where 
+
+import CharIO
+import Control.Monad.Identity
+import Data.Monoid
+import Doc.DocLike
+import FindFixpoint
+import FlagDump as FD
+import HsSyn
+import List 
+import Maybe
+import MultiModuleBasics
+import Name
+import Options
+import Prelude hiding (putStr,putStrLn)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Relation as R
+import Warning
+
+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 ([ m | Module 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 =  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 $ 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
+    
addfile ./FrontEnd/FrontEnd.hs
hunk ./FrontEnd/FrontEnd.hs 1
+module FrontEnd.FrontEnd(  
+    parseFiles, 
+    TiData(..)
+    ) where
+
+import Doc.DocLike
+import FrontEnd.Exports
+import FrontEnd.Rename
+import GenUtil
+import Ho
+import HsSyn              
+import Monad
+import MultiModuleBasics
+import Options
+import qualified FlagDump as FD
+import qualified Data.Map as Map
+import qualified PPrint
+import TIModule
+import Utils
+import Warning
+
+
+
+-- | Main entry point to front end
+    
+parseFiles :: [String]      -- ^ List of files to read
+               -> [Module]  -- ^ List of modules to find
+               -> (Ho -> Ho -> TiData -> IO Ho)  -- ^ routine which takes the global ho, the partial local ho and the output of the front end, and returns the completed ho.
+               -> IO Ho     -- ^ the final combined ho.
+parseFiles fs deps func = do
+    wdump FD.Progress $ do
+        putErrLn $ "Compiling " ++ show fs
+    let xs = snub $ map Right fs ++ map Left deps
+        f ho [] = return ho
+        f ho (x:xs) = do 
+            ho' <- findModule ho x (doModules func)
+            f ho' xs
+    ho <- f initialHo xs 
+    processIOErrors
+    when (dump FD.AllKind) $
+         do {putStrLn " ---- kind information ---- \n";
+             putStr $ PPrint.render $ pprintEnvMap (hoKinds ho)}
+    --when  (dump FD.AllDcons) $
+    --    do {putStr " ---- data constructor assumptions ---- \n";
+    --         putStrLn $ PPrint.render $ pprintEnv (hoDConsAssumptions ho)}
+    return ho
+
+doModules :: (Ho -> Ho -> TiData -> IO Ho) -> Ho -> [HsModule] -> IO Ho 
+doModules func ho ms  = do
+    ms <- mapM modInfo ms
+    --putErrLn $ show (hoExports ho)
+    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 ho] (Map.toList $ hoExports ho) ms 
+    (ho',tiData) <- tiModules' ho ms
+    ho'' <- func ho ho' tiData
+    return ho''
+    --me <- foldM tiModules emptyModEnv mss
+
+modInfo m = do
+    opt <- case fileOptions (hsModuleOptions m) of 
+        Right o -> return o
+        Left s -> warn (srcLoc m) "unknown-option" ("Unknown OPTIONS in pragma module" <+> fromModule (hsModuleName m) <+>  s) >> 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
+        }  
+    
+
+
+
+
+--modInfoDeps m = snub $ map hsImportDeclModule $ modInfoModImports m 
+    
+
+{-
+doTime str action = do
+    start <- getCPUTime
+    x <- action 
+    end <- getCPUTime
+    putStrLn $ "Timing: " ++ str ++ " " ++ show ((end - start) `div` cpuTimePrecision)
+    return x
+
+parseHsSource :: String -> String -> IO HsModule
+--parseHsSource fn s = case parse s' (SrcLoc fn 1 1) 0 [] of
+parseHsSource fn s = case runParserWithMode ParseMode { parseFilename = fn } parse  s'  of
+                      ParseOk e -> return e 
+                      ParseFailed sl err -> putErrDie $ show sl ++ err 
+    where 
+    s' = if "shl." `isPrefixOf` reverse fn  then unlit fn s else s
+                      -- warnF fn "parse-error" err >> return emptyHsModule
+
+satisfyDeps :: [String] -> [String] -> IO [HsModule]
+satisfyDeps have [] = return []
+satisfyDeps have (n:ns) | n `elem` have = satisfyDeps have ns
+satisfyDeps have (n:ns) = do
+    let fns n = concatMap (\i -> [i ++ "/" ++ n ++ ".hs",i ++ "/" ++ n ++ ".lhs"]) (optIncdirs options)
+    (fn,fc) <- catch (msum (map (\n -> CharIO.readFile n >>= return . (,) n) (fns n))) (\_ -> putErrDie ("Module not found: " ++ n)) 
+    wdump FD.Progress $ do
+        putErrLn $ "Found dependency:" <+> n <+> "at" <+> fn  
+    hm <- parseHsSource fn fc 
+    rm <- satisfyDeps (n:have) (ns ++ hsModuleRequires hm) 
+    return (hm:rm)
+
+readFiles :: [String] -> IO [HsModule]
+readFiles fs = do
+    ss <- fmap (zip fs) $ mapM CharIO.readFile fs
+    mapM (uncurry parseHsSource) ss
+
+-}
+
+
+{-
+parseFiles :: [String] -> [String] -> IO ModEnv
+parseFiles fs deps = do
+    wdump FD.Progress $ do
+        putErrLn $ "Compiling " ++ show fs
+    ms <- readFiles fs
+    let mh = [(fromModule (hsModuleName hsm)) | hsm <- ms ]
+        mn = concat [ hsModuleRequires x | x <- ms ]
+    ms' <- satisfyDeps mh (mn ++ deps)
+    ms <- return $ ms ++ ms'
+    ms <- mapM modInfo ms
+    --wdump FD.Progress $ do
+    --    putErrLn $ "Determining exports and imports"
+    --mis <- determineExports ms -- (map modInfo ms)
+    --processIOErrors
+--    let me = M.fromList [( (modInfoName m), m) | m <- mis ]
+--        --ps = [ (fromModule (hsModuleName hsm), (if optPrelude options then ("Prelude":) else id) [fromModule (hsImportDeclModule i) | i <- hsModuleImports hsm] ) | hsm <-  ms]
+--        ps = [ (modInfoName m, modInfoDeps m)  | m <- mis ]
+--        nodes   = map fst ps
+--        targets = concat (map snd ps)
+--    unless (all (`elem` nodes) targets) $
+--        putErrDie $ "Modules not found!\n" ++ show ps
+--    let ps' = Scc.scc ps
+--        ps'' = map (map (me M.!)) ps'
+    let mss' = stronglyConnComp [ (m,toAtom (modInfoName m), map toAtom (modInfoDeps m))  | m <- ms]    
+        mss = map f mss' 
+        f (AcyclicSCC x) = [x]
+        f (CyclicSCC xs) = xs
+    when (dump FD.SccModules) $ putStrLn $ "scc modules:\n" ++ unlines (map  (show . map (fromModule . modInfoName) ) mss)
+    mss <- doExports [] mss []
+    me <- foldM tiModules emptyModEnv mss
+    when (dump FD.AllKind) $
+         do {putStrLn " ---- kind information ---- \n";
+             putStr $ PPrint.render $ pprintEnvMap (modEnvKinds me)}
+    when  (dump FD.AllDcons) $
+         do {putStr " ---- data constructor assumptions ---- \n";
+             putStrLn $ PPrint.render $ pprintEnv (modEnvDConsAssumptions me)}
+    processIOErrors
+    return me
+-}
+    
+
+{-
+
+type Entity = Name
+--exports ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing } } _ = 
+--        case namesHsModule m of { (xs,ts) -> R.fromList $ [ ((False,n),n) | (n,_) <- xs] ++ [ ((True,n),n) | (n,_) <- ts];   }
+exports :: ModInfo -> Rel (Name) Entity -> Rel (Name) Entity 
+exports mi@ModInfo { modInfoHsModule = m@HsModule { hsModuleExports = Nothing } } _ = defsToRel $ modInfoDefs mi
+exports mi is | HsModule { hsModuleExports = Just es } <- modInfoHsModule mi = mapDomain h (R.unions $ map f es) where
+    f (HsEModuleContents m) = mapDomain g unqs `R.intersection` qs where  
+        (qs,unqs) = partitionDomain (isJust . getModule ) is
+        --g (x,UnQual i) = (x,Qual m i)
+        g x = Name.qualifyName m x
+    f z = entSpec False is z 
+    h n = toUnqualified n
+
+imports :: ModInfo -> (Module -> Rel (Name) Entity) -> Rel (Name) Entity -> Rel (Name) Entity 
+imports mi em rel = mconcatMap f is where
+    f x = rel `mappend` z where
+        z = (mapDomain (\n -> (Name.qualifyName as n)) es `mappend` if hsImportDeclQualified x then mempty else es)
+        Just as = hsImportDeclAs x `mplus` Just (hsImportDeclModule x)
+        es = em (hsImportDeclModule x) 
+    
+    is = modInfoModImports mi
+    --is' = hsModuleImports $ modInfoHsModule mi
+    --is = is' ++ if any ( (== Module "Prelude") . hsImportDeclModule) is' then [] else [prelude]
+    --prelude = HsImportDecl { hsImportDeclSrcLoc = bogusASrcLoc, hsImportDeclModule = Module "Prelude", hsImportDeclSpec = Nothing, hsImportDeclAs = Nothing, hsImportDeclQualified = False }
+    
+--mEntSpec isHiding rel es  
+ determineExports ::  MonadWarn m => (Map.Map Module  (Rel Name Name) ) -> [ModInfo] -> m [ModInfo]
+determineExports soFar mi = mapM g [ (m,i,o) | (i,o) <- lfp start | m <- mi] where
+    start = [(h m,mempty) |  m <- mi]
+    f xs = [ (imports m mp i, o `mappend` exports m i) | (m,i,o) <- z] where 
+        z = [ (m,i,o) | m <- mi | (i,o) <- xs]
+        mp :: Module -> Rel Name Entity
+        mp m = case M.lookup m (soFar `mappend` M.fromList [ (modInfoName m,o)  | (m,_,o) <- z ]) of
+            Nothing -> error $ "Could not find Module Exports for: " ++ show m
+            Just x -> x
+    lfp x = let fx = f x in if fx == x then fx else lfp fx
+    g (m,i,o) = ce m o >>= \o' -> ci i >>= \i' -> return m { modInfoExport = o', modInfoImport = i' }
+    h m = R.fromList $  concat [ [(toUnqualified z,z),(z,z)]| (z, _, _) <- modInfoDefs m] 
+    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)
+    ci x = mapM f (toRelationList x) where
+        f (x,[]) = error "can't happen"
+        f (x,ys) = return (x,ys)
+ 
+hsModuleRequires x = (if optPrelude options then ("Prelude":) else id) [ fromModule $ hsImportDeclModule y | y <- hsModuleImports x]
+
+    {-
+parseFile verb mi fn = do
+    src <- readFile fn
+    moduleSyntax <- parseHsSource fn src
+    x <- tiModule (if verb then ["all"] else []) moduleSyntax mi
+    return $ x `joinModuleInfo` mi
+-}
+-}
addfile ./FrontEnd/HsErrors.hs
hunk ./FrontEnd/HsErrors.hs 1
+-- |
+-- Routines to check for several error and warning conditions which can be locally determined from syntax.
+--
+
+module HsErrors where
+
+import HsSyn
+import Warning
+import VConsts
+import Class
+import Monad
+
+
+
+
+hsType :: MonadWarn m => HsType -> m ()
+hsType x@HsTyForall {} = do
+    err "h98-forall" "Explicit quantification is a non-haskell98 feature"
+    hsQualType (hsTypeType x) 
+hsType x = mapHsTypeHsType (\x -> hsType x >> return x) x >> return ()
+
+hsQualType x  = hsType (hsQualTypeType x)
+
+
+
+hsDecl :: MonadWarn m => HsDecl -> m ()
+hsDecl HsDataDecl { hsDeclSrcLoc = sl, hsDeclCons = cs, hsDeclDerives = ds } = do
+    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 && classEnum `elem` ds) $ warn sl "derive-enum" "Cannot derive enum from non enumeration type"
+    when (not isEnum && length cs /= 1 && classBounded `elem` ds) $ warn sl "derive-bounded" "Cannot derive bounded from non enumeration or unary type"
+    return ()
+hsDecl HsNewTypeDecl { hsDeclSrcLoc = sl, hsDeclDerives = ds } = do
+    checkDeriving sl True ds
+    return ()
+hsDecl _ = return ()
+
+
+
+--derivable = [ "Eq","Ord","Enum","Bounded","Show","Read" ]
+
+checkDeriving _ _ xs | all (`elem` derivableClasses) xs = return ()
+checkDerining sl True _ = warn sl "h98-newtypederiv" "arbitrary newtype derivations are a non-haskell98 feature"
+checkDerining sl False _ = warn sl "unknown-deriving" "attempt to derive from a non-derivable class"
+
+    
+
+mapHsTypeHsType f (HsTyFun a b) = do 
+    a <- f a 
+    b <- f b
+    return $ HsTyFun a b
+mapHsTypeHsType f (HsTyTuple xs) = do
+    xs <- mapM f xs
+    return $ HsTyTuple xs
+mapHsTypeHsType f (HsTyApp a b) = do 
+    a <- f a 
+    b <- f b
+    return $ HsTyApp a b
+mapHsTypeHsType f (HsTyForall vs qt) = do 
+    x <- f $ hsQualTypeType qt
+    return $ HsTyForall vs qt { hsQualTypeType = x }
+mapHsTypeHsType _ x = return x
+    
+
addfile ./FrontEnd/HsParser.ly
hunk ./FrontEnd/HsParser.ly 1
+-----------------------------------------------------------------------------
+$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 HsSyn
+> import FrontEnd.ParseMonad 
+> import FrontEnd.Lexer
+> import FrontEnd.ParseUtils hiding(readInteger,readRational)
+> 
+>
+>
+> }
+
+-----------------------------------------------------------------------------
+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 $$ }
+>	RATIONAL { FloatTok $$ }
+>	CHAR	 { Character $$ }
+>	STRING   { StringTok $$ }
+>       PRAGMAOPTIONS { PragmaOptions $$ }
+>       PRAGMASTART { PragmaStart $$ }
+>       PRAGMAEND { PragmaEnd }
+
+Symbols
+
+>	'('	{ LeftParen }
+>	')'	{ RightParen }
+>	';'	{ 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 }
+>	'*'	{ Star }
+>	'.'	{ Dot }
+
+Reserved Ids
+
+>	'as'		{ KW_As }
+>	'case'		{ KW_Case }
+>	'class'		{ KW_Class }
+>	'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 }
+
+> %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 = Nothing, 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) }
+> 	|  '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 }
+>	: 'type' simpletype srcloc '=' type	
+>			{ HsTypeDecl $3 (fst $2) (snd $2) $5 }
+>       | 'data' ctype srcloc deriving
+>           {% checkDataHeader $2 `thenP` \(cs,c,t) -> 
+>              returnP (HsDataDecl $3 cs c t [] $4) }
+>	| 'data' ctype srcloc '=' constrs deriving
+>			{% checkDataHeader $2 `thenP` \(cs,c,t) ->
+>			   returnP (HsDataDecl $3 cs c t (reverse $5) $6) }
+>	| 'newtype' ctype srcloc '=' constr deriving
+>			{% checkDataHeader $2 `thenP` \(cs,c,t) ->
+>			   returnP (HsNewTypeDecl $3 cs c t $5 $6) }
+>	| 'class' srcloc ctype optcbody	
+>			{ HsClassDecl $2 $3 $4 }
+>	| 'instance' srcloc ctype optvaldefs	
+>			{ HsInstDecl $2 $3 $4 }
+>	| 'default' srcloc type		
+>			{ HsDefaultDecl $2 $3 }
+>	| srcloc 'foreign' 'import' cconv STRING var '::' ctype
+>			{ HsForeignDecl $1 $4 $5 $6 $8}
+>	| srcloc 'foreign' 'import' cconv var '::' ctype
+>			{ HsForeignDecl $1 $4 (show $5) $5 $7}
+>       | decl		{ $1 }
+
+> cconv :: { ForeignType }
+>        : varid  { if show $1 == "primitive" then ForeignPrimitive else ForeignCCall }
+
+> 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] }
+
+-----------------------------------------------------------------------------
+Types
+
+> type :: { HsType }
+>	: btype '->' type		{ HsTyFun $1 $3 }
+>	| btype				{ $1 }
+>       | 'forall' tbinds '.' ctype     { HsTyForall { 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 }
+
+> btype :: { HsType }
+>	: btype atype			{ HsTyApp $1 $2 }
+>	| atype				{ $1 }
+
+> atype :: { HsType }
+>	: gtycon			{ HsTyCon $1 }
+>	| tyvar				{ HsTyVar $1 }
+>	| '(' types ')'			{ HsTyTuple (reverse $2) }
+>	| '[' type ']'			{ HsTyApp list_tycon $2 }
+>	| '(' type ')'			{ $2 }
+
+> 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				{ HsUnQualType $1 }
+
+> types	:: { [HsType] }
+>	: types ',' type		{ $3 : $1 }
+>	| type  ',' type		{ [$3, $1] }
+
+> simpletype :: { (HsName, [HsName]) }
+>	: tycon tyvars			{ ($1,reverse $2) }
+
+> tyvars :: { [HsName] }
+>	: tyvars tyvar			{ $2 : $1 }
+>	| {- empty -}			{ [] }
+
+-----------------------------------------------------------------------------
+Datatype declarations
+
+> constrs :: { [HsConDecl] }
+>	: constrs '|' constr		{ $3 : $1 }
+>	| constr			{ [$1] }
+
+> constr :: { HsConDecl }
+>	: srcloc scontype		{ HsConDecl $1 (fst $2) (snd $2) }
+>	| srcloc sbtype conop sbtype	{ HsConDecl $1 $3 [$2,$4] }
+>	| srcloc con '{' fielddecls '}' 
+>					{ HsRecDecl $1 $2 (reverse $4) }
+
+> 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' '{' cbody '}'			{ fixupHsDecls $3 }
+>	| 'where' layout_on cbody close		{ fixupHsDecls $3 }
+>	| {- empty -}				{ [] }
+
+> cbody :: { [HsDecl] }
+>	: cmethods ';' cdefaults optsemi	{ reverse $1 ++ reverse $3 }
+>	| cmethods optsemi			{ reverse $1 }
+>	| optsemi				{ [] }
+
+> cmethods :: { [HsDecl] }
+>	: cmethods ';' signdecl			{ $3 : $1 }
+>	| signdecl				{ [$1] }
+
+> cdefaults :: { [HsDecl] }
+>	: cdefaults ';' valdef			{ $3 : $1 }
+>	| valdef				{ [$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 }
+>	: 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 }
+>   	| '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) }
+>	| '[' list ']'                  { $2 }
+>	| '(' infixexp qop ')'		{ HsLeftSection $3 $2  }
+>	| '(' qopm infixexp ')'		{ HsRightSection $3 $2 }
+>	| qvar '@' aexp1		{% checkUnQual $1 `thenP` \n ->
+>					   returnP (HsAsPat n $3) }
+>	| srcloc '_'			{ HsWildCard $1 }
+>	| '~' aexp1			{ HsIrrPat $2 }
+
+> 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 :: { HsGuardedAlts }
+>	: '->' exp				{ HsUnGuardedAlt $2 }
+>	| gdpats				{ HsGuardedAlts (reverse $1) }
+
+> gdpats :: { [HsGuardedAlt] }
+>	: gdpats gdpat				{ $2 : $1 }
+>	| gdpat					{ [$1] }
+
+> gdpat	:: { HsGuardedAlt }
+>	: '|' exp srcloc '->' exp 		{ HsGuardedAlt $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 }
+>	| 'qualified'		{ qualified_name }
+>	| 'hiding'		{ hiding_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 }
+>	| '*'			{ star_name }
+>	| '.'			{ dot_name }
+
+> varsymm :: { HsName } -- varsym not including '-'
+>	: VARSYM		{ UnQual (hsSymbol $1) }
+>	| '!'			{ pling_name }
+>	| '*'			{ star_name }
+>	| '.'			{ dot_name }
+
+> qvarsym1 :: { HsName }
+>	: QVARSYM		{ Qual (Module (fst $1)) (hsSymbol (snd $1)) }
+
+> literal :: { HsExp }
+>	: INT 			{ HsLit (HsInt (readInteger $1)) }
+>	| CHAR 			{ HsLit (HsChar $1) }
+>	| RATIONAL		{ HsLit (HsFrac (readRational $1)) }
+>	| STRING		{ HsLit (HsString $1) }
+
+>  srcloc :: { SrcLoc }	:	{% getSrcLoc }
+ 
+-----------------------------------------------------------------------------
+Layout
+
+> close :: { () }
+>	: vccurly		{ () } -- context popped in lexer.
+>	| error			{% popContext }
+
+> layout_on  :: { () }	:	{% getSrcLoc `thenP` \sl ->
+>				   pushCurrentContext  }
+
+				   pushCurrentContext (Layout (srcLocColumn sl)) }
+
+-----------------------------------------------------------------------------
+Miscellaneous (mostly renamings)
+
+> modid :: { Module }
+>	: CONID			{ 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 }
+
+-----------------------------------------------------------------------------
+
+> {
+> happyError = parseError "Parse error"
+> hsSymbol x = HsIdent x
+> readInteger x = fromIntegral x
+> readRational x = x
+> }
addfile ./FrontEnd/HsPretty.hs
hunk ./FrontEnd/HsPretty.hs 1
+-----------------------------------------------------------------------------
+--  $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 HsPretty (PPLayout(..),PPHsMode(..),defaultMode,
+		render, renderWithMode,
+		ppHsModule,ppHsModuleHeader,
+		ppHsDecl,
+		ppHsDecls,
+		ppHsQualType, ppHsType,
+		ppHsExp,
+                ppMatch,
+                ppHsStmt,
+                ppHsPat,
+                ppHsAlt,
+                ppGAlt,
+                ppHsGuardedRhs,
+                ppHsName,
+		ppHsQName) where
+
+import HsSyn
+import qualified PPrint as P
+import qualified Text.PrettyPrint.HughesPJ as P
+import Options
+import FlagDump as FD
+import Char
+import VConsts
+import FrontEnd.Rename(unRename)
+
+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
+
+empty :: Doc
+empty = return P.empty
+
+nest :: Int -> Doc -> Doc
+nest i m = m >>= return . P.nest i 
+
+dropAs (HsAsPat _ e) = e
+dropAs e = e
+
+-- Literals
+
+text, ptext :: String -> Doc
+text = return . P.text
+ptext = return . P.text
+
+char :: Char -> Doc
+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
+
+rational :: Rational -> Doc
+rational = return . P.rational
+
+-- Simple Combining Forms
+
+parens, brackets, braces,quotes,doubleQuotes :: Doc -> Doc
+parens d = d >>= return . P.parens
+brackets d = d >>= return . P.brackets
+braces d = d >>= return . P.braces
+quotes d = d >>= return . P.quotes
+doubleQuotes d = d >>= return . P.doubleQuotes
+
+-- Constants
+
+semi,comma,colon,space,equals :: Doc
+semi = return P.semi
+comma = return P.comma
+colon = return P.colon
+space = return P.space
+equals = return P.equals
+
+lparen,rparen,lbrack,rbrack,lbrace,rbrace :: Doc
+lparen = return  P.lparen
+rparen = return  P.rparen
+lbrack = return  P.lbrack
+rbrack = return  P.rbrack
+lbrace = return  P.lbrace
+rbrace = return  P.rbrace
+
+-- Combinators
+
+(<>),(<+>),($$),($+$) :: Doc -> Doc -> Doc
+aM <> bM = do{a<-aM;b<-bM;return (a P.<> b)}
+aM <+> bM = do{a<-aM;b<-bM;return (a P.<+> b)}
+aM $$ bM = do{a<-aM;b<-bM;return (a P.$$ b)}
+aM $+$ bM = do{a<-aM;b<-bM;return (a P.$+$ b)}
+
+hcat,hsep,vcat,sep,cat,fsep,fcat :: [Doc] -> Doc
+hcat dl = sequence dl >>= return . P.hcat
+hsep dl = sequence dl >>= return . P.hsep
+vcat dl = sequence dl >>= return . P.vcat
+sep dl = sequence dl >>= return . P.sep
+cat dl = sequence dl >>= return . P.cat
+fsep dl = sequence dl >>= return . P.fsep
+fcat dl = sequence dl >>= return . P.fcat
+
+-- Some More
+
+hang :: Doc -> Int -> Doc -> Doc
+hang dM i rM = do{d<-dM;r<-rM;return $ P.hang d i r}
+
+-- Yuk, had to cut-n-paste this one from Pretty.hs
+punctuate :: Doc -> [Doc] -> [Doc]
+punctuate p []     = []
+punctuate p (d:ds) = go d ds
+                   where
+                     go d [] = [d]
+                     go d (e:es) = (d <> p) : go e es
+
+
+
+-- this is the equivalent of runM now.
+renderWithMode :: PPHsMode -> Doc -> String
+renderWithMode ppMode d = P.render . unDocM d $ ppMode
+
+render :: Doc -> String
+render = renderWithMode defaultMode
+
+fullRenderWithMode :: PPHsMode -> P.Mode -> Int -> Float -> 
+		      (P.TextDetails -> a -> a) -> a -> Doc -> a
+fullRenderWithMode ppMode m i f fn e mD = 
+		   P.fullRender m i f fn e $ (unDocM mD) ppMode
+
+
+fullRender :: P.Mode -> Int -> Float -> (P.TextDetails -> a -> a) 
+	      -> a -> Doc -> a
+fullRender = fullRenderWithMode 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)
+
+-------------------------  Declarations ------------------------------
+ppHsDecl :: HsDecl -> Doc
+ppHsDecl (HsForeignDecl _ _ s n qt) = text "ForeignDecl" <+> ppHsName n <+> ppHsQualType qt
+ppHsDecl (HsTypeDecl loc name nameList htype) = 
+	   --blankline $
+	   mySep ( [text "type",ppHsName name] 
+		   ++ map ppHsName nameList
+		   ++ [equals, ppHsType htype])
+
+ppHsDecl (HsDataDecl loc context name nameList constrList 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)  
+
+-- 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 -------------------------
+ppHsConstr :: HsConDecl -> Doc
+ppHsConstr (HsRecDecl pos name fieldList) =
+	 ppHsName name
+	 <> (braceList . map ppField $ fieldList)
+ppHsConstr (HsConDecl pos name typeList)
+     | isSymbolName name && length typeList == 2 =
+	 let [l, r] = typeList in
+	 myFsep [ppHsBangType l, ppHsName name, ppHsBangType r]
+     | otherwise =
+	 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]
+ppHsQualType (HsUnQualType htype) = 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 (HsTyTuple l) = parenList . map ppHsType $ l
+-- special case
+ppHsTypePrec p (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsIdent "[]"))) b ) =
+	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 (Qual (Module "Prelude") n)) = ppHsNameParen (UnQual n)
+ppHsTypePrec p (HsTyCon name) = ppHsQName name
+
+------------------------- 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 _ (HsVar n)) = 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 (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
+-- 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 exp)) =
+	myFsep[ppHsName name <> char '@', char '~' <> ppHsExp exp]
+ppHsExp (HsAsPat name exp) = hcat[ppHsName name,char '@',ppHsExp exp]
+ppHsExp (HsWildCard _) = char '_'
+ppHsExp (HsIrrPat 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 (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 pat)) =
+	myFsep[ppHsName name <> char '@', char '~' <> ppHsPat pat]
+ppHsPat	(HsPAsPat name pat) = hcat[ppHsName name,char '@',ppHsPat pat]
+ppHsPat	HsPWildCard = char '_'
+ppHsPat	(HsPIrrPat 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 :: HsGuardedAlts -> Doc
+ppGAlts (HsUnGuardedAlt exp) = text "->" <+> ppHsExp exp
+ppGAlts (HsGuardedAlts altList) = myVcat . map ppGAlt $ altList
+
+ppGAlt (HsGuardedAlt 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) 
+	 | m == prelude_mod && isSpecialName z = ppHsIdentifier name
+	 | otherwise = text mod <> char '.' <> ppHsIdentifier name
+
+ppHsName = ppHsQName
+
+ppHsQNameParen :: HsName -> Doc
+ppHsQNameParen name = parensIf (isSymbolName (getName name)) (ppHsQName name)
+
+ppHsQNameInfix :: HsName -> Doc
+ppHsQNameInfix name
+	| isSymbolName (getName 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
+
+isSpecialName :: HsName -> Bool
+--isSpecialName (Qual _ (HsSpecial _)) = True
+--isSpecialName (UnQual (HsSpecial _)) = True
+isSpecialName _ = False
+
+getName :: HsName -> HsName
+--getName (UnQual s) = s
+--getName (Qual _ s) = s
+getName = id
+
+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 (a,ts) = myFsep(ppHsQName a : [ppHsName ts])
+
+------------------------- 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
+
+braceList :: [Doc] -> Doc
+braceList = braces . myFsepSimple . punctuate comma
+
+bracketList :: [Doc] -> Doc
+bracketList = brackets . myFsepSimple
+
+-- Monadic PP Combinators -- these examine the env
+
+blankline :: Doc -> Doc
+blankline dl = do{e<-getPPEnv;if spacing e && layout e /= PPNoLayout
+			      then space $$ dl else dl}
+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  
addfile ./FrontEnd/HsSyn.hs
hunk ./FrontEnd/HsSyn.hs 1
+module HsSyn where
+
+
+
+import Data.Generics
+import Atom
+import PackedString
+import Binary
+import Data.Monoid
+
+bogusASrcLoc = SrcLoc "bogus#" (-1) (-1)
+bogusSrcSpan = srcSpan bogusASrcLoc bogusASrcLoc
+
+
+data SrcLoc = SrcLoc { srcLocFileName :: String, srcLocLine :: !Int, srcLocColumn :: !Int} 
+    deriving(Data,Typeable,Eq,Ord)
+    {-! derive: update, GhcBinary !-}
+
+data SrcSpan = SrcSpan { srcSpanBegin :: !SrcLoc, srcSpanEnd :: !SrcLoc }
+    deriving(Data,Typeable,Eq,Ord) 
+    {-! derive: update !-}
+
+srcSpan :: SrcLoc -> SrcLoc -> SrcSpan
+srcSpan = SrcSpan
+
+instance Monoid SrcLoc where 
+    mempty = bogusASrcLoc
+    mappend a b 
+        | a == bogusASrcLoc = b
+        | otherwise = a
+
+    
+
+class HasLocation a where
+    srcLoc :: a -> SrcLoc
+    getSrcSpan :: a -> SrcSpan
+    getSrcSpan x = bogusSrcSpan { srcSpanBegin = srcLoc x }
+
+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 _ = bogusASrcLoc
+
+
+instance HasLocation a => HasLocation [a] where
+    srcLoc xs = mconcat (map srcLoc xs)
+    srcLoc [] = bogusASrcLoc
+
+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 } ) = show sl1 ++ "-" ++ show sl2 
+
+newtype Module = Module String 
+  deriving(Data,Typeable,Eq,Ord,Show,ToAtom,FromAtom)
+
+fromModule (Module s) = s
+
+data ForeignType = ForeignPrimitive | ForeignCCall
+    deriving(Data,Typeable, Eq, Ord, Show)
+
+data HsName
+	= Qual { hsNameModule :: Module, hsNameIdent ::  HsIdentifier}
+	| UnQual { hsNameIdent :: HsIdentifier}
+  deriving(Data,Typeable,Eq,Ord)
+  {-! derive: is, update, GhcBinary !-}
+
+
+instance ToAtom HsName where
+    toAtom = Atom.fromString . show 
+
+instance Show HsName where
+   showsPrec _ (Qual (Module m) s) = 
+	showString m . showString "." . shows s
+   showsPrec _ (UnQual s) = shows s
+
+newtype HsIdentifier = HsIdent { hsIdentString :: String }
+  deriving(Data,Typeable,Eq,Ord)
+
+instance Binary Module where
+    get bh = do
+        ps <- get bh
+        return (Module $ unpackPS ps)
+    put_ bh (Module n) = put_ bh (packString n)
+    
+instance Binary HsIdentifier where
+    get bh = do
+        ps <- get bh
+        return (HsIdent $ unpackPS ps)
+    put_ bh (HsIdent n) = put_ bh (packString 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
+
+instance HasLocation HsModule where
+    srcLoc x = hsModuleSrcLoc x
+
+data HsModule = HsModule { 
+    hsModuleName :: Module, 
+    hsModuleSrcLoc :: SrcLoc,
+    hsModuleExports :: (Maybe [HsExportSpec]), 
+    hsModuleImports :: [HsImportDecl], 
+    hsModuleDecls :: [HsDecl], 
+    hsModuleOptions :: [String]
+    }
+  deriving(Data,Typeable, Show)
+  {-! derive: update !-}
+
+-- Export/Import Specifications
+
+data HsExportSpec
+	 = HsEVar HsName		-- variable
+	 | HsEAbs HsName		-- T
+	 | HsEThingAll HsName		-- T(..)
+	 | HsEThingWith HsName [HsName]	-- T(C_1,...,C_n)
+	 | HsEModuleContents Module	-- module M   (not for imports)
+  deriving(Data,Typeable,Eq,Show)
+
+instance HasLocation HsImportDecl where
+    srcLoc x = hsImportDeclSrcLoc x
+
+
+data HsImportDecl = HsImportDecl { 
+    hsImportDeclSrcLoc :: SrcLoc, 
+    hsImportDeclModule :: Module, 
+    hsImportDeclQualified :: !Bool, 
+    hsImportDeclAs :: (Maybe Module), 
+    hsImportDeclSpec :: (Maybe (Bool,[HsImportSpec])) 
+    }
+  deriving(Data,Typeable,Eq,Show)
+
+data HsImportSpec
+	 = HsIVar HsName		-- variable
+	 | HsIAbs HsName		-- T
+	 | HsIThingAll HsName		-- T(..)
+	 | HsIThingWith HsName [HsName]	-- T(C_1,...,C_n)
+  deriving(Data,Typeable,Eq,Show)
+
+data HsAssoc = HsAssocNone | HsAssocLeft | HsAssocRight
+  deriving(Data,Typeable,Eq,Show)
+  {-! derive: GhcBinary !-}
+
+instance HasLocation HsDecl where
+    srcLoc HsTypeDecl	 { hsDeclSrcLoc  = sl } = sl
+    srcLoc HsDataDecl	 { hsDeclSrcLoc  = sl } = sl
+    srcLoc HsInfixDecl   { hsDeclSrcLoc = sl } = sl
+    srcLoc HsNewTypeDecl { hsDeclSrcLoc = sl } = sl
+    srcLoc (HsClassDecl	 sl _ _) = sl
+    srcLoc (HsInstDecl	 sl _ _) = sl
+    srcLoc (HsDefaultDecl sl _) = sl
+    srcLoc (HsTypeSig	 sl _ _) = sl
+    srcLoc (HsFunBind     ms) = srcLoc ms
+    srcLoc (HsPatBind	 sl _ _ _) = sl
+    srcLoc (HsForeignDecl sl _ _ _ _) = sl
+    srcLoc (HsPragmaProps sl _ _) = sl
+
+
+data HsDecl
+	 = HsTypeDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclName :: HsName, hsDeclArgs :: [HsName], hsDeclType :: HsType }
+	 | HsDataDecl	 { hsDeclSrcLoc :: SrcLoc, hsDeclContext :: HsContext, hsDeclName :: HsName, hsDeclArgs :: [HsName], hsDeclCons :: [HsConDecl], {- deriving -} hsDeclDerives :: [HsName] }
+	 | HsInfixDecl   { hsDeclSrcLoc :: SrcLoc, hsDeclAssoc :: HsAssoc, hsDeclInt :: !Int, hsDeclNames :: [HsName]  }
+	 | HsNewTypeDecl { hsDeclSrcLoc :: SrcLoc, hsDeclContext :: HsContext, hsDeclName :: HsName, hsDeclArgs :: [HsName], hsDeclCon :: HsConDecl, {- deriving -} hsDeclDerives :: [HsName] }
+	 | HsClassDecl	 SrcLoc HsQualType [HsDecl]
+	 | HsInstDecl	 SrcLoc HsQualType [HsDecl]
+	 | HsDefaultDecl SrcLoc HsType
+	 | HsTypeSig	 SrcLoc [HsName] HsQualType
+	 | HsFunBind     [HsMatch]
+	 | HsPatBind	 SrcLoc HsPat HsRhs {-where-} [HsDecl]
+	 | HsForeignDecl SrcLoc ForeignType String HsName HsQualType
+         | HsPragmaProps SrcLoc String [HsName]
+  deriving(Data,Typeable,Eq,Show)
+  {-! derive: is !-}
+
+instance HasLocation HsMatch where
+    srcLoc (HsMatch sl _ _ _ _) = sl
+
+data HsMatch 
+	 = HsMatch SrcLoc HsName [HsPat] HsRhs {-where-} [HsDecl]
+  deriving(Data,Typeable,Eq,Show)
+
+data HsConDecl
+	 = HsConDecl { hsConDeclSrcLoc :: SrcLoc, hsConDeclName :: HsName, hsConDeclConArg :: [HsBangType] }
+	 | HsRecDecl { hsConDeclSrcLoc :: SrcLoc, hsConDeclName :: HsName, hsConDeclRecArg :: [([HsName],HsBangType)] }
+  deriving(Data,Typeable,Eq,Show)
+  {-! derive: is !-}
+
+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(Data,Typeable,Eq,Show)
+
+data HsRhs
+	 = HsUnGuardedRhs HsExp
+	 | HsGuardedRhss  [HsGuardedRhs]
+  deriving(Data,Typeable,Eq,Show)
+
+data HsGuardedRhs
+	 = HsGuardedRhs SrcLoc HsExp HsExp
+  deriving(Data,Typeable,Eq,Show)
+
+data HsQualType
+	 = HsQualType   { hsQualTypeContext :: HsContext, hsQualTypeType :: HsType }
+	 | HsUnQualType { hsQualTypeType :: HsType }
+  deriving(Data,Typeable,Eq,Ord,Show)
+  {-! derive: GhcBinary !-}
+
+hsQualTypeHsContext HsQualType { hsQualTypeContext = c } = c
+hsQualTypeHsContext _ = []
+
+data HsType
+	 = HsTyFun   HsType HsType
+	 | HsTyTuple [HsType]
+	 | HsTyApp   HsType HsType
+	 | HsTyVar   { hsTypeName :: HsName }
+	 | HsTyCon   { hsTypeName :: HsName }
+         | HsTyForall { 
+            hsTypeVars :: [HsTyVarBind], 
+            hsTypeType :: HsQualType }
+  deriving(Data,Typeable,Eq,Ord,Show)
+  {-! derive: GhcBinary !-}
+
+data HsTyVarBind = HsTyVarBind { 
+    hsTyVarBindSrcLoc :: SrcLoc, 
+    hsTyVarBindName :: HsName, 
+    hsTyVarBindKind :: Maybe HsKind }
+  deriving(Data,Typeable,Eq,Ord,Show)
+  {-! derive: GhcBinary !-}
+
+hsTyVarBind = HsTyVarBind { hsTyVarBindSrcLoc = bogusASrcLoc, hsTyVarBindName = undefined, hsTyVarBindKind = Nothing }
+
+instance HasLocation HsTyVarBind where
+    srcLoc = hsTyVarBindSrcLoc
+
+type HsContext = [HsAsst]
+--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(Data,Typeable,Eq,Ord, Show)
+    {-! derive: is !-}
+
+hsParen x@HsVar {} = x
+hsParen x@HsCon {} = x
+hsParen x@HsParen {} = x
+hsParen x@HsLit {} = x
+hsParen x@HsTuple {} = x
+hsParen x = HsParen x
+
+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]
+	| 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
+	| HsWildCard SrcLoc			-- ditto
+	| HsIrrPat HsExp		-- ditto
+ deriving(Data,Typeable,Eq,Show)
+    {-! derive: is, update !-}
+
+data HsPat
+	= HsPVar { hsPatName :: HsName }
+	| HsPLit { hsPatLit :: HsLiteral }
+	| HsPNeg HsPat
+	| HsPInfixApp HsPat HsName HsPat
+	| HsPApp { hsPatName :: HsName, hsPatPats :: [HsPat] }
+	| HsPTuple [HsPat]
+	| HsPList [HsPat]
+	| HsPParen HsPat
+	| HsPRec HsName [HsPatField]
+	| HsPAsPat { hsPatName :: HsName, hsPatPat :: HsPat }
+	| HsPWildCard
+	| HsPIrrPat HsPat
+	| HsPTypeSig SrcLoc HsPat HsQualType  -- scoped type variable extension
+ deriving(Data,Typeable,Eq,Ord,Show)
+ {-! derive: is !-}
+
+data HsPatField
+	= HsPFieldPat HsName HsPat
+ deriving(Data,Typeable,Eq,Ord,Show)
+
+data HsStmt
+	= HsGenerator SrcLoc HsPat HsExp       -- srcloc added by bernie
+	| HsQualifier HsExp
+	| HsLetStmt [HsDecl]
+ deriving(Data,Typeable,Eq,Show)
+
+data HsFieldUpdate
+	= HsFieldUpdate HsName HsExp
+  deriving(Data,Typeable,Eq,Show)
+
+data HsAlt
+	= HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl]
+  deriving(Data,Typeable,Eq,Show)
+
+data HsGuardedAlts
+	= HsUnGuardedAlt HsExp
+	| HsGuardedAlts  [HsGuardedAlt]
+  deriving(Data,Typeable,Eq,Show)
+
+data HsGuardedAlt
+	= HsGuardedAlt SrcLoc HsExp HsExp
+  deriving(Data,Typeable,Eq,Show)
+
+data HsKind = HsKind {-# UNPACK #-} !Atom | HsKindFn HsKind HsKind
+  deriving(Data,Typeable,Eq,Ord,Show)
+  {-! derive: GhcBinary !-}
+
+hsKindStar = HsKind (fromString "*")
+
+-----------------------------------------------------------------------------
+-- Builtin names.
+
+prelude_mod	      = Module "Prelude"
+main_mod	      = Module "Main"
+
+--unit_con_name	      = Qual prelude_mod (HsSpecial "()")
+unit_con_name	      = UnQual (HsIdent "()")
+tuple_con_name i      = Qual prelude_mod (HsIdent ("("++replicate i ','++")"))
+
+unit_con	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = unit_con_name }
+tuple_con i	      = HsCon { {-hsExpSrcSpan = bogusSrcSpan,-} hsExpName = (tuple_con_name i) }
+
+as_name	              = UnQual $ HsIdent "as"
+qualified_name        = UnQual $ HsIdent "qualified"
+hiding_name	      = UnQual $ HsIdent "hiding"
+minus_name	      = UnQual $ HsIdent "-"
+pling_name	      = UnQual $ HsIdent "!"
+star_name	      = UnQual $ HsIdent "*"
+dot_name	      = UnQual $ HsIdent "."
+
+unit_tycon_name       = unit_con_name
+fun_tycon_name        = Qual prelude_mod (HsIdent "->")
+list_tycon_name       = UnQual (HsIdent "[]")
+--list_tycon_name       = Qual prelude_mod (HsIdent "[]")
+tuple_tycon_name i    = tuple_con_name i
+
+unit_tycon	      = HsTyCon unit_tycon_name
+fun_tycon	      = HsTyCon fun_tycon_name
+list_tycon	      = HsTyCon list_tycon_name
+tuple_tycon i	      = HsTyCon (tuple_tycon_name i)
addfile ./FrontEnd/Infix.hs
hunk ./FrontEnd/Infix.hs 1
+{-------------------------------------------------------------------------------
+
+        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) where
+
+import HsSyn
+import qualified Data.Map as Map
+import Data.Monoid
+import Name
+import DDataUtil
+import Binary
+import MapBinaryInstance
+import HasSize
+
+----------------------------------------------------------------------------
+
+type FixityInfo = (Int, HsAssoc)
+--type OpKey      = (Module, HsIdentifier)
+--type SymbolMap = FiniteMap OpKey FixityInfo
+type SymbolMap = Map.Map Name FixityInfo
+
+newtype FixityMap = FixityMap SymbolMap
+    deriving(Monoid,Binary,HasSize)
+
+
+----------------------------------------------------------------------------
+
+
+ -- 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)
+
+unqualModule :: Module              -- The module which unqualified operators are associated with.
+unqualModule = Module "Prelude"
+
+----------------------------------------------------------------------------
+
+  -- infixer(): The exported top-level function. See header for usage.
+
+infixHsModule :: Monad m => FixityMap -> HsModule -> m HsModule
+infixHsModule (FixityMap ism) m = return $ hsModuleDecls_u f m where
+    f = map (processDecl ism)
+    --ism = buildSMap is
+
+    
+    
+
+
+--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
+    _                                       -> decl
+    where
+        proc_decls decls = map (processDecl infixMap) decls
+
+
+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 -> HsGuardedAlts -> HsGuardedAlts 
+processGAlts infixMap g_alts = case g_alts of
+    HsUnGuardedAlt exp     -> HsUnGuardedAlt $ fst $ processExp infixMap exp
+    HsGuardedAlts galts    -> HsGuardedAlts $ map (processGAlt infixMap) galts
+
+
+processGAlt :: SymbolMap -> HsGuardedAlt -> HsGuardedAlt
+processGAlt infixMap (HsGuardedAlt srcloc e1 e2) = HsGuardedAlt 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 (pp p)
+    HsPApp n xs -> tf $ HsPApp n (map pp xs)
+    HsPTuple xs -> tf $ HsPTuple (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)
+    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 (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)
+
+------------------------------------------------------------------------------
addfile ./FrontEnd/KindInfer.hs
hunk ./FrontEnd/KindInfer.hs 1
+
+-- | 
+-- 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 KindInfer (kiDecls,
+                  KindEnv, 
+                  hsQualTypeToScheme,
+                  hsAsstToPred,
+                  kindOfClass,
+                  kindOf,
+                  ) where 
+
+import Representation hiding (Subst)
+import HsSyn  
+import Utils 
+import List (nub)
+import DependAnalysis              
+import Control.Monad
+import MonadUtil
+import Data.Generics
+import qualified Seq
+import Data.IORef
+import System.IO.Unsafe
+import Type(quantify,tv,tTTuple)
+import qualified Data.Map as Map
+
+
+
+--------------------------------------------------------------------------------
+
+-- the many interesting types and classes
+
+type KindEnv = Map.Map HsName Kind
+
+type Subst = [(Kindvar, Kind)]
+
+nullSubst :: Subst
+nullSubst = []
+
+class Kinds a where
+   vars :: a -> [Kindvar]
+   apply :: Subst -> a -> a
+
+instance Kinds Kind where
+   vars Star = []
+   vars (KVar kindvar) = [kindvar]
+   vars (kind1 `Kfun` kind2) = vars kind1 ++ vars kind2 
+
+   apply s Star = Star 
+   apply s (KVar kindvar) 
+      = case lookup kindvar s of
+           Just k -> k
+           Nothing -> KVar kindvar
+   apply s (kind1 `Kfun` kind2)
+      = (apply s kind1) `Kfun` (apply s kind2)
+
+instance Kinds a => Kinds [a] where
+   vars = nub . concatMap vars 
+   apply s = map (apply s)
+
+instance Kinds a => Kinds (b, a) where
+   apply s (x, y) = (x, apply s y)
+   vars (x, y) = vars y
+
+instance Kinds KindEnv where
+   apply s = Map.map (\el -> apply s el) 
+   vars env = vars $ map snd $ Map.toList env
+
+
+--------------------------------------------------------------------------------
+
+-- unification
+
+composeSubst :: Subst -> Subst -> Subst
+composeSubst s1 s2 = [(u, apply s1 k) | (u, k) <- s2] ++ s1
+
+
+{-# SPECIALIZE mgu :: Kind -> Kind -> KI Subst #-}
+
+-- can return either a substitution or a string
+mgu :: Monad m => Kind -> Kind -> m Subst
+mgu Star Star = return nullSubst
+mgu (k1 `Kfun` k2) (k3 `Kfun` k4) = do
+    s1 <- mgu k1 k3
+    s2 <- mgu (apply s1 k2) (apply s1 k4)
+    return (s2 `composeSubst` s1)
+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
+
+{-# SPECIALIZE varBind :: Kindvar -> Kind -> KI Subst #-}
+
+varBind :: Monad m => Kindvar -> Kind -> m Subst
+varBind u k
+   | k == KVar u = return nullSubst
+   | u `elem` vars k = fail $ "occurs check failed in kind inference: " ++ 
+                               show u ++ ", " ++ show k  
+   | otherwise = return [(u, k)]
+
+
+--------------------------------------------------------------------------------
+
+-- The kind inference monad
+
+data KiEnv  = KiEnv {
+    kiContext :: [String],
+    kiEnv :: IORef KindEnv,
+    kiSubst :: IORef Subst,
+    kiVarnum :: IORef Int
+    }
+
+newtype KI a = KI (KiEnv -> IO a)-- -> (a, State))
+
+
+instance Monad KI where
+    return a = KI (\_ -> return a) 
+    KI comp >>= fun
+        = KI (\v  -> comp v >>= \r -> case fun r   of KI x -> x v) 
+    fail x = KI (\s -> fail (unlines $ reverse (x:kiContext s)))
+
+data State = State {
+      env :: KindEnv,     -- the environment of kind assumptions 
+      subst :: Subst     -- the current substitution
+   }
+
+
+--------------------------------------------------------------------------------
+
+-- useful operations in the inference monad
+
+--runKI     :: KindEnv -> KI a -> (a, State)
+--runKI kindEnv (KI comp) = (result, newState) where 
+--   (result,newState) = comp (State { context = [], env = kindEnv, subst = nullSubst, varnum = 0})
+
+runKI :: KindEnv -> KI a -> IO (a, State)
+runKI env (KI ki) = (kienv >>= ki') where
+    kienv = do
+        env <- newIORef env
+        subst <- newIORef nullSubst
+        varnum <- newIORef 0
+        return KiEnv { kiContext = [], kiEnv = env, kiSubst = subst, kiVarnum = varnum }
+    ki' e = do
+        x <- ki e
+        env <- readIORef (kiEnv e)
+        subst <- readIORef (kiSubst e)
+        return (x,State { env = env, subst = subst })
+        
+
+{- INLINE select #-}
+--select :: (State -> a) -> KI a
+--select selector = KI (\state -> (selector state, state))
+
+{-
+instance ContextMonad KI where 
+    withContext nc (KI x)= KI (\s ->case  x (s { context = nc :context s }) of (r,s') -> (r,s' { context = context s }) )
+-}
+instance ContextMonad String KI where 
+    withContext nc (KI x)= KI (\s -> x s { kiContext = nc :kiContext s })
+
+getSubst :: KI Subst
+getSubst = KI $ \e -> do
+    readIORef (kiSubst e) 
+
+getVarNum :: KI Int
+getVarNum = KI $ \e -> do
+    readIORef (kiVarnum e) 
+
+getEnv :: KI (KindEnv)
+getEnv = KI $ \e -> do
+    readIORef (kiEnv e) 
+
+
+getEnvVars :: KI [Kindvar]
+getEnvVars 
+   = do e <- getEnv
+        return $ vars e 
+
+incVarNum :: KI ()
+incVarNum = KI $ \e -> do
+    n <- readIORef (kiVarnum e) 
+    writeIORef (kiVarnum e ) $! (n + 1)
+    --modifyIORef (kiVarnum e) (+ 1)
+    --KI (\state -> let oldVarNum = varnum state
+    --                      in ((), state {varnum = oldVarNum + 1}))
+
+unify :: Kind -> Kind -> KI ()
+unify k1 k2 = do 
+    s <- getSubst
+    newSubst <- mgu (apply s k1) (apply s k2)
+    extendSubst newSubst
+    --case mgu (apply s k1) (apply s k2) of
+    --       Right newSubst  -> extendSubst newSubst 
+    --       Left errorMsg -> error $ unlines (reverse c ++ [errorMsg]) 
+
+
+extendSubst :: Subst -> KI ()
+extendSubst s = KI $ \e -> do
+    modifyIORef (kiSubst e) (s `composeSubst`)
+
+--(\state -> let oldSub = subst state
+--                              in ((), state {subst = s `composeSubst` oldSub}))
+newKindVar :: KI Kind
+newKindVar 
+   = do n <- getVarNum
+        incVarNum
+        return (KVar (Kindvar n))
+
+lookupKindEnv :: HsName -> KI (Maybe Kind)
+lookupKindEnv name
+   = do env <- getEnv
+        return $ Map.lookup name env 
+
+extendEnv :: KindEnv -> KI ()
+extendEnv newEnv = KI $ \e ->
+    modifyIORef (kiEnv e) (`Map.union` newEnv)
+--   = KI (\state -> let oldEnv = env state
+--                   in ((), state {env = oldEnv `joinEnv` newEnv}))
+    
+applySubstToEnv :: Subst -> KI ()
+applySubstToEnv subst = KI $ \e ->
+    modifyIORef (kiEnv e) (apply subst)
+--   = KI (\state -> let oldEnv    = env state
+--                   in ((), state {env = apply subst oldEnv}))
+
+envVarsToStars :: KI ()
+envVarsToStars 
+   = do vars <- getEnvVars
+        let varsToStarSubst = map (\v -> (v, Star)) vars   -- clobber all remaining variables to stars
+        applySubstToEnv varsToStarSubst
+ 
+
+--------------------------------------------------------------------------------
+
+-- kind inference proper
+-- this is what gets called from outside of this module
+kiDecls :: KindEnv -> [HsDecl] -> IO KindEnv
+kiDecls inputEnv classAndDataDecls = run >>= return . env . snd  where
+   run =   runKI inputEnv $ mapM_ kiKindGroup kindGroups
+   kindGroups = map declsToKindGroup depGroups
+   depGroups = getDataAndClassBg classAndDataDecls 
+
+kiKindGroup :: KindGroup -> KI () 
+kiKindGroup tap@(classDecls, heads, context, dataBodies, classBodies) = do
+        withContext ("kiKindGroup: " ++ show tap) $ do
+        mapM_ kiClassDecl classDecls
+        mapM_ kiTyConDecl heads
+        mapM_ kiAsst context
+        dataBodyKinds <- mapM (kiType True) dataBodies        -- vars must be seen previously here (hence True)
+        --mapM_ (\k -> unify k Star) dataBodyKinds
+        classBodyKinds <- mapM (kiQualType False) classBodies  -- vars may not have been seen previously here (hence False)
+        --mapM_ (\k -> unify k Star) classBodyKinds
+        currentSubst <- getSubst
+        applySubstToEnv currentSubst
+        envVarsToStars
+        
+
+kiTyConDecl :: DataDeclHead -> KI () 
+kiTyConDecl (tyconName, args) = do
+        argKindVars <- mapM newNameVar args
+        let tyConKind = foldr Kfun Star $ map snd argKindVars
+        let newEnv = Map.fromList $ [(tyconName, tyConKind)] ++ argKindVars
+        extendEnv newEnv
+
+kiClassDecl :: (HsName,[HsName]) -> KI ()
+--kiClassDecl nn | trace ("kiClassDecl: " ++ show nn) False = undefined
+kiClassDecl (className, argNames) = do
+        varKind <- newKindVar 
+        let newEnv = Map.fromList $ (className, varKind): [(argName, varKind) | argName <- argNames]
+        extendEnv newEnv
+
+-- here we expext the classname to be already defined and should be in the
+-- environment, we do not require that the variables will be defined
+kiAsst :: HsAsst -> KI Kind
+kiAsst x@(className, argName) = withContext ("kiAsst: " ++ show x) $ do
+    classKind <- lookupKindEnv className
+    case classKind of
+           Nothing -> error $ "kiAsst: could not find kind information for class: " ++ show className
+           Just ck -> do argKind <- lookupKindEnv argName
+                         case argKind of
+                            --Nothing -> error  $ "kiAsst: could not find kind information for class/arg: " ++ show className ++ "/" ++ show argName
+                            Nothing -> do varKind <- newKindVar
+					  extendEnv $ Map.singleton argName varKind
+                                          unify ck varKind
+                                          return ck 
+                            Just ak -> do unify ck ak
+                                          return ck
+                                       
+kiQualType :: Bool -> HsQualType -> KI Kind
+kiQualType varExist qt@(HsQualType cntxt t) = do 
+        withContext ("kiQualType: " ++ show qt) $ do
+        mapM_ kiAsst cntxt
+        kiType varExist t
+--kiQualType varExist (HsUnQualType t)
+--   = kiType varExist t
+
+
+-- boolean arg = True = throw error if var does not exist
+--               False = if var does not exist then add it to the environment
+
+kiType :: Bool -> HsType -> KI Kind 
+kiType _ tap@(HsTyCon name) = do 
+        withContext ("kiType: " ++ show tap) $ do
+        tyConKind <- lookupKindEnv name 
+        case tyConKind of
+           Nothing 
+              -> do env <- getEnv
+                    error $ "kiType: could not find kind for this constructor: " ++ show name ++
+                         "\nin this kind environment:\n" ++ show env
+           Just k -> return k
+
+kiType varExist tap@(HsTyVar name) = do 
+        withContext ("kiType: " ++ show tap) $ do
+        varKind <- lookupKindEnv name 
+        case varKind of
+           Nothing 
+              -> case varExist of
+                    True 
+                       -> error $ "kiType: could not find kind for this type variable: " ++ show name  
+                    False -> do varKind <- newKindVar
+				extendEnv $ Map.singleton name varKind
+                                return varKind
+           Just k -> return k
+
+-- kind(t1) = kind(t2) -> var
+
+kiType varExist tap@(HsTyApp t1 t2) = do
+        withContext ("kiType: " ++ show tap) $ do
+        k1 <- kiType varExist t1
+        k2 <- kiType varExist t2
+        varKind <- newKindVar
+        unify k1 (k2 `Kfun` varKind) 
+        return varKind 
+
+-- kind(->) = * -> * -> *
+-- kind (t1 -> t2) = *, |- kind(t1) = *, kind(t2) = *
+
+
+kiType varExist tap@(HsTyFun t1 t2) = do
+        withContext ("kiType: " ++ show tap) $ do
+        k1 <- kiType varExist t1
+        k2 <- kiType varExist t2 
+        unify k1 Star
+        unify k2 Star
+        return Star 
+
+-- kind (t1, t2, ..., tn) = *
+-- |- kind(t1) = *, kind(t2) = *, ... , kind(tn) = *
+
+kiType varExist tap@(HsTyTuple ts) = do
+        withContext ("kiType: " ++ show tap) $ do
+        tsKs <- mapM (kiType varExist) ts
+        mapM_ (\k -> unify k Star) tsKs
+        return Star 
+
+newNameVar :: HsName -> KI (HsName, Kind)
+newNameVar n 
+   = do
+        newVar <- newKindVar
+        return (n, newVar) 
+
+
+-------------------------------------------------------------------------------- 
+
+-- code for getting the kinds of variables in type sigs
+
+kiHsQualType :: KindEnv -> HsQualType -> KindEnv
+kiHsQualType inputEnv qualType = env newState where
+    (_, newState) = unsafePerformIO $ runKI inputEnv $ do 
+        kiQualType False qualType
+        envVarsToStars
+
+{-
+kiHsQualTypePredPred :: KindEnv -> HsQualType -> KindEnv
+kiHsQualTypePredPred inputEnv qt@(HsQualType cntxt (HsTyApp (HsTyCon className) t))  = env newState where
+    (_, newState) = runKI inputEnv $ do 
+        withContext ("kiQualTypePredPred: " ++ show qt) $ do
+        mapM_ kiAsst (cntxt)
+        kt <- kiType False t
+        Just ck <- lookupKindEnv className
+        unify kt ck
+        envVarsToStars
+-}
+
+--------------------------------------------------------------------------------
+
+getDataAndClassBg :: [HsDecl] -> [[HsDecl]]
+getDataAndClassBg decls 
+   = getBindGroups decls getDeclName dataAndClassDeps 
+
+dataAndClassDeps :: HsDecl -> [HsName]
+dataAndClassDeps (HsDataDecl _sloc cntxt _name _args condecls _derives)
+   = nub $ namesFromContext cntxt ++ (concatMap namesFromType $ concatMap conDeclToTypes condecls)
+dataAndClassDeps (HsNewTypeDecl _sloc cntxt _name _args condecl _derives)
+   = nub $ namesFromContext cntxt ++ (concatMap namesFromType $ conDeclToTypes condecl)
+dataAndClassDeps (HsClassDecl _sloc (HsQualType cntxt _classApp) decls)
+   = nub $ namesFromContext cntxt ++ (concat [ namesFromQualType (typeFromSig s) | s <- decls,  isSigDecl s])
+dataAndClassDeps (HsClassDecl _sloc (HsUnQualType _classApp) decls)
+   = nub $ concat [ namesFromQualType (typeFromSig s) | s <- decls,  isSigDecl s]
+
+namesFromQualType :: HsQualType -> [HsName]
+namesFromQualType (HsQualType cntxt t)
+   = namesFromContext cntxt ++ namesFromType t
+namesFromQualType (HsUnQualType t)
+   = namesFromType t
+
+namesFromType :: HsType -> [HsName]
+namesFromType (HsTyFun t1 t2)
+   = namesFromType t1 ++ namesFromType t2
+namesFromType (HsTyTuple ts)
+   = concatMap namesFromType ts
+namesFromType (HsTyApp t1 t2)
+   = namesFromType t1 ++ namesFromType t2
+namesFromType (HsTyVar _) = []
+namesFromType (HsTyCon n) = [n]
+
+namesFromContext :: HsContext -> [HsName]
+namesFromContext cntxt
+   = map fst cntxt
+
+--------------------------------------------------------------------------------
+
+-- (type constructor name, arguments to constructor)
+type DataDeclHead = (HsName, [HsName])
+-- (class decls, data decl heads, class and data contexts, types in body of data decl, types in body of class)
+type KindGroup = ([(HsName,[HsName])], [DataDeclHead], HsContext, [HsType], [HsQualType])
+
+declsToKindGroup :: [HsDecl] -> KindGroup
+declsToKindGroup [] = ([], [], [], [], [])
+
+declsToKindGroup ((HsDataDecl _sloc context tyconName tyconArgs condecls _derives):decls)
+   = (restClassDecls, 
+      newHead:restDataHeads, 
+      context++restContext, 
+      newBodies ++ restDataBodies, 
+      restClassBodies)
+   where
+   (restClassDecls, restDataHeads, restContext, restDataBodies, restClassBodies) 
+      = declsToKindGroup decls
+   newHead = (tyconName, tyconArgs)
+   newBodies = concatMap conDeclToTypes condecls
+
+declsToKindGroup ((HsNewTypeDecl _sloc context tyconName tyconArgs condecl _derives):decls)
+   = (restClassDecls, 
+      newHead:restDataHeads, 
+      context++restContext, 
+      newBodies ++ restDataBodies, 
+      restClassBodies)
+   where
+   (restClassDecls, restDataHeads, restContext, restDataBodies, restClassBodies) 
+      = declsToKindGroup decls
+   newHead = (tyconName, tyconArgs)
+   newBodies = conDeclToTypes condecl
+
+
+declsToKindGroup (HsClassDecl _sloc qualType sigsAndDefaults : decls)
+   = (newClassDecl:restClassDecls, 
+      restDataHeads, 
+      newContext++restContext, 
+      restDataBodies, 
+      newClassBodies++restClassBodies)
+   where
+   (restClassDecls, restDataHeads, restContext, restDataBodies, restClassBodies) = declsToKindGroup decls
+   newClassBodies = map typeFromSig $ filter isSigDecl sigsAndDefaults
+   --rn = runIdentity $ applyTU (full_tdTU $ adhocTU (constTU ([])) f) newClassBodies 
+   --f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = return [n']
+   --f _ = return []
+   rn = Seq.toList $ everything (Seq.<>) (mkQ Seq.empty f) newClassBodies 
+   f (HsTyVar n') | hsNameToOrig n' == hsNameToOrig classArg = Seq.single n'
+   f _ = Seq.empty
+   (newClassDecl, newContext) = ((className, classArg:rn), contxt)
+   HsQualType contxt (HsTyApp (HsTyCon className) (HsTyVar classArg)) =  qualType
+
+
+conDeclToTypes :: HsConDecl -> [HsType]
+conDeclToTypes rd = map bangTypeToType (hsConDeclArgs rd)
+--conDeclToTypes (HsConDecl _sloc name bangTypes)
+--   = map bangTypeToType bangTypes
+--   = error $ "conDeclToType (HsRecDecl _lsoc _name _recs): not implemented yet"
+
+bangTypeToType :: HsBangType -> HsType
+bangTypeToType (HsBangedTy t) = t
+bangTypeToType (HsUnBangedTy t) = t
+
+typeFromSig :: HsDecl -> HsQualType
+typeFromSig (HsTypeSig _sloc _names qualType) = qualType
+
+--------------------------------------------------------------------------------
+
+kindOf :: HsName -> KindEnv -> Kind
+kindOf name env 
+   = case Map.lookup name env of
+        Nothing -> Star
+        Nothing -> error $ "kindOf: could not find kind of : " ++ show name
+        Just k -> k
+
+kindOfClass :: HsName -> KindEnv -> [Kind]
+kindOfClass name env 
+   = case Map.lookup name env of
+        --Nothing -> Star
+        Nothing -> error $ "kindOf: could not find kind of class : " ++ show name
+        Just k -> [k]
+
+----------------------
+-- Conversion of Types
+----------------------
+    
+-- note that the types are generated without generalised type
+-- variables, ie there will be no TGens in the output
+-- to get the generalised variables a second phase
+-- of generalisation must be applied
+
+aHsTypeToType :: KindEnv -> HsType -> Type
+aHsTypeToType kt (HsTyFun t1 t2) = aHsTypeToType kt t1 `fn` aHsTypeToType kt t2
+aHsTypeToType kt tuple@(HsTyTuple 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 $ tyvar  name (kindOf name kt)
+
+-- 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 name (kindOf name kt)
+aHsTypeToType _ t = error $ "aHsTypeToType: " ++ show t
+
+
+aHsQualTypeToQualType :: KindEnv -> HsQualType -> Qual Type
+aHsQualTypeToQualType kt (HsQualType cntxt t)
+   = map (hsAsstToPred kt) cntxt :=> aHsTypeToType kt t
+aHsQualTypeToQualType kt (HsUnQualType t)
+   = [] :=> aHsTypeToType kt t
+
+-- this version quantifies all the type variables
+-- perhaps there should be a version that is 
+-- parameterised with which variables to quantify
+
+aHsQualTypeToScheme :: KindEnv -> HsQualType -> Scheme
+aHsQualTypeToScheme kt qualType
+   = quantify vars qt
+   where
+   qt = aHsQualTypeToQualType kt qualType
+   vars = tv qt 
+
+hsAsstToPred :: KindEnv -> HsAsst -> Pred
+hsAsstToPred kt (className, varName)
+   -- = IsIn className (TVar $ Tyvar varName (kindOf varName kt)) 
+   = IsIn className (TVar $ tyvar varName (head $ kindOfClass className kt)) 
+ 
+hsQualTypeToScheme :: Monad m => KindEnv -> HsQualType -> m Scheme
+hsQualTypeToScheme kt qualType =  return $ aHsQualTypeToScheme newEnv qualType where  
+   newEnv = kiHsQualType kt qualType 
addfile ./FrontEnd/Lexer.hs
hunk ./FrontEnd/Lexer.hs 1
+-- #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 FrontEnd.ParseMonad
+
+import Data.Char
+import Data.Ratio
+import qualified Data.Map as Map
+
+data Token
+        = VarId String
+        | QVarId (String,String)
+	| ConId String
+        | QConId (String,String)
+        | VarSym String
+        | ConSym String
+        | QVarSym (String,String)
+        | QConSym (String,String)
+	| IntTok Integer
+	| FloatTok Rational
+	| Character Char
+        | StringTok String
+        | PragmaOptions [String]
+        | PragmaStart String 
+        | PragmaEnd
+
+-- Symbols
+
+	| LeftParen
+	| RightParen
+	| 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
+	| Exclamation
+	| Star
+	| Dot
+
+-- Reserved Ids
+
+	| KW_As
+	| KW_Case
+	| KW_Class
+	| KW_Data
+	| KW_Default
+	| KW_Deriving
+	| KW_Do
+	| KW_Else
+        | KW_Hiding
+	| KW_If
+	| KW_Import
+	| KW_In
+	| KW_Infix
+	| KW_InfixL
+	| KW_InfixR
+	| KW_Instance
+	| KW_Let
+	| KW_Module
+	| KW_NewType
+	| KW_Of
+	| KW_Then
+	| KW_Type
+	| KW_Where
+	| KW_Qualified
+	| KW_Foreign
+	| KW_Forall
+
+        | 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
+ ( "!",  Exclamation ),	--ditto
+ ( ".",  Dot ),		--ditto
+ ( "*",  Star )		--ditto
+ ]
+
+reserved_ids :: [(String,Token)]
+reserved_ids = [
+ ( "_",         Underscore ),
+ ( "case",      KW_Case ),
+ ( "class",     KW_Class ),
+ ( "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 ),
+ ( "where", 	KW_Where )
+ ]
+
+special_varids :: [(String,Token)]
+special_varids = [
+ ( "as", 	KW_As ),
+ ( "qualified", KW_Qualified ),
+ ( "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
+	s <- getInput
+	case s of
+            '{':'-':'#':s | takeWhile isAlphaNum (dropWhile isSpace s) `Map.member` pragmas -> return bol  
+	    '{':'-':_ -> 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':_ -> do
+		lexNewline
+		lexWhiteSpace True
+	    '\t':_ -> do
+		lexTab
+		lexWhiteSpace bol
+	    c:_ | isSpace c -> do
+		discard 1
+		lexWhiteSpace bol
+	    _ -> return bol
+
+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
+    case s of
+        [] -> return EOF
+        '{':'-':'#':s' -> do
+            discard 3
+            lexWhile isSpace 
+            w <- lexWhile isAlphaNum
+            case normPragma w  of 
+                (False,w') -> return (PragmaStart w')
+                (True,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
+			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 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"
+			    return (Character c2)
+
+		    '"' ->  lexString
+
+		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")
+
+lexDecimalOrFloat :: Lex a Token
+lexDecimalOrFloat = do
+	ds <- lexWhile isDigit
+	rest <- getInput
+	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))
+	    _ -> 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 = loop ""
+    where
+	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)
+		    '"':_ -> 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 ()
+
+lexEscape :: Lex a Char
+lexEscape = do
+	discard 1
+	r <- getInput
+	case r of
+
+-- Production charesc from section B.2 (Note: \& is handled by caller)
+
+		'a':_		-> discard 1 >> return '\a'
+		'b':_		-> discard 1 >> return '\b'
+		'f':_		-> discard 1 >> return '\f'
+		'n':_		-> discard 1 >> return '\n'
+		'r':_		-> discard 1 >> return '\r'
+		't':_		-> discard 1 >> return '\t'
+		'v':_		-> discard 1 >> return '\v'
+		'\\':_		-> discard 1 >> return '\\'
+		'"':_		-> discard 1 >> return '\"'
+		'\'':_		-> discard 1 >> return '\''
+
+-- Production ascii from section B.2
+
+		'^':c:_		-> discard 2 >> cntrl c
+		'N':'U':'L':_	-> discard 3 >> return '\NUL'
+		'S':'O':'H':_	-> discard 3 >> return '\SOH'
+		'S':'T':'X':_	-> discard 3 >> return '\STX'
+		'E':'T':'X':_	-> discard 3 >> return '\ETX'
+		'E':'O':'T':_	-> discard 3 >> return '\EOT'
+		'E':'N':'Q':_	-> discard 3 >> return '\ENQ'
+		'A':'C':'K':_	-> discard 3 >> return '\ACK'
+		'B':'E':'L':_	-> discard 3 >> return '\BEL'
+		'B':'S':_	-> discard 2 >> return '\BS'
+		'H':'T':_	-> discard 2 >> return '\HT'
+		'L':'F':_	-> discard 2 >> return '\LF'
+		'V':'T':_	-> discard 2 >> return '\VT'
+		'F':'F':_	-> discard 2 >> return '\FF'
+		'C':'R':_	-> discard 2 >> return '\CR'
+		'S':'O':_	-> discard 2 >> return '\SO'
+		'S':'I':_	-> discard 2 >> return '\SI'
+		'D':'L':'E':_	-> discard 3 >> return '\DLE'
+		'D':'C':'1':_	-> discard 3 >> return '\DC1'
+		'D':'C':'2':_	-> discard 3 >> return '\DC2'
+		'D':'C':'3':_	-> discard 3 >> return '\DC3'
+		'D':'C':'4':_	-> discard 3 >> return '\DC4'
+		'N':'A':'K':_	-> discard 3 >> return '\NAK'
+		'S':'Y':'N':_	-> discard 3 >> return '\SYN'
+		'E':'T':'B':_	-> discard 3 >> return '\ETB'
+		'C':'A':'N':_	-> discard 3 >> return '\CAN'
+		'E':'M':_	-> discard 2 >> return '\EM'
+		'S':'U':'B':_	-> discard 3 >> return '\SUB'
+		'E':'S':'C':_	-> discard 3 >> return '\ESC'
+		'F':'S':_	-> discard 2 >> return '\FS'
+		'G':'S':_	-> discard 2 >> return '\GS'
+		'R':'S':_	-> discard 2 >> return '\RS'
+		'U':'S':_	-> discard 2 >> return '\US'
+		'S':'P':_	-> discard 2 >> return '\SP'
+		'D':'E':'L':_	-> discard 3 >> return '\DEL'
+
+-- Escaped numbers
+
+		'o':c:_ | isOctDigit c -> do
+					discard 1
+					n <- lexOctal
+					checkChar n
+		'x':c:_ | isHexDigit c -> do
+					discard 1
+					n <- lexHexadecimal
+					checkChar n
+		c:_ | isDigit c -> do
+					n <- lexDecimal
+					checkChar n
+
+		_		-> fail "Illegal escape sequence"
+
+    where
+	checkChar n | n <= 0x01FFFF = return (chr (fromInteger n))
+	checkChar _		    = fail "Character constant out of range"
+
+-- Production cntrl from section B.2
+
+	cntrl :: Char -> Lex a Char
+	cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))
+	cntrl _                        = fail "Illegal control character"
+
+-- assumes at least one octal digit
+lexOctal :: Lex a Integer
+lexOctal = do
+	ds <- lexWhile isOctDigit
+	return (parseInteger 8 ds)
+
+-- assumes at least one hexadecimal digit
+lexHexadecimal :: Lex a Integer
+lexHexadecimal = do
+	ds <- lexWhile isHexDigit
+	return (parseInteger 16 ds)
+
+-- assumes at least one decimal digit
+lexDecimal :: Lex a Integer
+lexDecimal = do
+	ds <- lexWhile isDigit
+	return (parseInteger 10 ds)
+
+-- Stolen from Hugs's Prelude
+parseInteger :: Integer -> String -> Integer
+parseInteger radix ds =
+	foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)
+
+-- pragmas for which we just want the raw contents of
+pragmas_raw = [["OPTIONS", "JHC_OPTIONS"]]
+-- pragmas for which we want to parse the insides of 
+pragmas_std = [
+    ["INLINE"], 
+    ["NOINLINE","NOTINLINE"], 
+    ["SPECIALIZE", "SPECIALISE"],
+    ["SRCLOC_ANNOTATE"]
+    ]
+
+
+pragmas = Map.fromList $ [ (y,(True,x)) | xs@(x:_)  <- pragmas_raw, y <- xs] ++  [ (y,(False,x)) | xs@(x:_)  <- pragmas_std , y <- xs]
+
+normPragma :: String -> (Bool,String)
+normPragma s | Just v <- Map.lookup s pragmas  = v
+
+
addfile ./FrontEnd/MultiModuleBasics.hs
hunk ./FrontEnd/MultiModuleBasics.hs 1
+{-------------------------------------------------------------------------------
+
+    this is not what this module does at all.
+
+        Copyright:              The Hatchet Team (see file Contributors)
+
+        Module:                 MultiModuleBasics
+
+        Description:            More Support code for type checking multi-module
+                                programs. 
+
+        Primary Authors:        Bryn Humberstone 
+
+        Notes:                  See the file License for license information
+
+-------------------------------------------------------------------------------}
+
+-- TODO - get rid of
+
+module MultiModuleBasics where
+
+import HsSyn
+import qualified Data.Map as M
+import DDataUtil()
+import Options
+import Name
+import FrontEnd.Infix
+
+--------------------------------------------------------------------------------
+
+
+data ModInfo = ModInfo {
+    modInfoName :: Module,
+    modInfoDefs :: [(Name,SrcLoc,[Name])],
+    modInfoConsArity :: [(Name,Int)],
+    modInfoExport :: [Name],
+    modInfoImport :: [(Name,[Name])],
+    modInfoHsModule :: HsModule,
+    modInfoOptions :: Opt
+    } 
+   {-! derive: update !-}
+
+instance Eq ModInfo where
+    a == b = modInfoName a == modInfoName b
+
+instance Ord ModInfo where
+    compare a b = compare (modInfoName a) (modInfoName b)
+ 
+
+{-
+
+data ModEnv = ModEnv {
+    modEnvModules :: M.Map Module ModInfo,
+    modEnvVarAssumptions :: Env Scheme,          -- used for typechecking 
+    modEnvDConsAssumptions :: Env Scheme,        -- used for typechecking 
+    modEnvAllAssumptions :: M.Map Name Scheme,          -- used for code generation
+    modEnvFixities :: FixityMap,
+    modEnvKinds :: KindEnv,                      -- used for typechecking
+    modEnvClassHierarchy :: ClassHierarchy,
+    modEnvTypeSynonyms :: TypeSynonyms,
+    modEnvLiftedInstances :: M.Map HsName HsDecl
+    } 
+   {-! derive: update, Monoid !-}
+
+emptyModEnv :: ModEnv
+emptyModEnv = mempty 
+
+-}
addfile ./FrontEnd/PPrint.hs
hunk ./FrontEnd/PPrint.hs 1
+-----------------------------------------------------------------------------
+-- PPrint:	Print functions
+-----------------------------------------------------------------------------
+
+--module PPrint(module PPrint, module Text.PrettyPrint.HughesPJ) where
+module PPrint(PPrint(..), module Text.PrettyPrint.HughesPJ, pretty) where
+import Text.PrettyPrint.HughesPJ
+import Doc.DocLike
+import Doc.PPrint
+
+pretty  :: PPrint Doc a => a -> String
+pretty   = render . pprint
+
+{-
+
+-----------------------------------------------------------------------------
+-- This module contains definitions that do not appear in the
+-- typeset version of the paper.
+
+-----------------------------------------------------------------------------
+-- Pretty printing; a replacement for Show:
+
+
+ppParen    :: Bool -> Doc -> Doc
+ppParen t x = if t then parens x else x
+
+class PPrint a where
+  pprint    :: a -> Doc
+
+  parPprint :: a -> Doc
+  parPprint  = parens . pprint
+
+  pplist    :: [a] -> Doc
+  pplist    xs = brackets (hcat (punctuate comma (map pprint xs)))
+
+  pptuple   :: [a] -> Doc
+  pptuple   xs = parens (hcat (punctuate comma (map pprint xs)))
+
+instance PPrint a => PPrint [a] where
+  pprint  = pplist
+
+instance PPrint Char where
+  pprint  = char
+  pplist  = text
+
+instance PPrint Integer where
+  pprint  = integer
+
+instance PPrint Int where
+  pprint  = int
+
+instance PPrint Float where
+  pprint  = float
+
+instance PPrint Double where
+  pprint  = double
+
+instance (PPrint a, PPrint b) => PPrint (a,b) where
+  pprint (x,y) = parens (sep [pprint x <> comma, pprint y])
+
+instance (PPrint a, PPrint b, PPrint c) => PPrint (a,b,c) where
+  pprint (x,y,z) = parens (sep [pprint x <> comma,
+                                pprint y <> comma,
+                                pprint z])
+
+-----------------------------------------------------------------------------
+-}
addfile ./FrontEnd/ParseMonad.hs
hunk ./FrontEnd/ParseMonad.hs 1
+-- #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(..), defaultParseMode,
+		runParserWithMode, runParser,
+		getSrcLoc, pushCurrentContext, popContext,thenP,returnP,
+		-- * Lexing
+		Lex(runL), getInput, discard, lexNewline, lexTab, lexWhile,
+		alternative, checkBOL, setBOL, startToken, getOffside,
+		pushContextL, popContextL
+	) where
+
+import HsSyn(SrcLoc(..))
+
+-- | The result of a parse.
+data ParseResult a
+	= ParseOk a		-- ^ The parse succeeded, yielding a value.
+	| 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]
+
+indentOfParseState :: ParseState -> Int
+indentOfParseState (Layout n:_) = n
+indentOfParseState _            = 0
+
+-- | 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
+		}
+
+-- | Default parameters for a parse,
+-- currently just a marker for an unknown filename.
+
+defaultParseMode :: ParseMode
+defaultParseMode = ParseMode {
+		parseFilename = "<unknown>"
+		}
+
+-- | 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 [] mode of
+	Ok _ a -> ParseOk 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
+getSrcLoc = P $ \_i _x _y l s _m -> Ok s l
+
+-- 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+1) (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 (ctxt:s) ()
+
+popContext :: P ()
+popContext = P $ \_i _x _y _l stk _m ->
+      case stk of
+   	(_:s) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $
+            Ok 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
+
+-- 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)
+
+-- | Discard the next character, which must be a newline.
+
+lexNewline :: Lex a ()
+lexNewline = Lex $ \cont -> P $ \(_:r) _x y -> runP (cont ()) r 1 (y+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
+
+-- 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 _ stk mode ->
+	let loc = SrcLoc {
+		srcLocFileName = parseFilename mode,
+		srcLocLine = y,
+		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 (ctxt:stk)
+
+popContextL :: String -> Lex a ()
+popContextL fn = Lex $ \cont -> P $ \r x y loc stk -> case stk of
+		(_:ctxt) -> runP (cont ()) r x y loc 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      
+
+
+-}
addfile ./FrontEnd/ParseUtils.hs
hunk ./FrontEnd/ParseUtils.hs 1
+-- #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
+	, checkAssertion	-- HsType -> P HsAsst
+	, checkDataHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
+	, checkClassHeader	-- HsQualType -> P (HsContext,HsName,[HsName])
+	, checkInstHeader	-- HsQualType -> P (HsContext,HsQName,[HsType])
+	, checkPattern		-- HsExp -> P HsPat
+	, checkPatterns	
+	, checkExpr		-- HsExp -> P HsExp
+	, checkValDef		-- SrcLoc -> HsExp -> HsRhs -> [HsDecl] -> P HsDecl
+	, checkClassBody	-- [HsDecl] -> P [HsDecl]
+	, checkUnQual		-- HsQName -> P HsName
+	, checkRevDecls		-- [HsDecl] -> P [HsDecl]
+        , readInteger
+        , readRational
+        , fixupHsDecls
+        , parseError
+ ) where
+
+import HsSyn
+import FrontEnd.ParseMonad
+import Char
+import Ratio
+
+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"
+
+-----------------------------------------------------------------------------
+-- Various Syntactic Checks
+
+checkContext :: HsType -> P HsContext
+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 (a,n)
+                tast _ = fail "Invalid Class. multiparameter?"
+                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)
+checkDataHeader (HsUnQualType t) = do
+	(c,ts) <- checkSimple "class" t []
+	return ([],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")
+
+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)
+	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 <- checkPat 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
+	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 :: HsGuardedAlts -> P HsGuardedAlts
+checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt
+checkGAlts (HsGuardedAlts galts) = do
+	galts <- mapM checkGAlt galts
+	return (HsGuardedAlts galts)
+
+checkGAlt :: HsGuardedAlt -> P HsGuardedAlt
+checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt 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
+
+-- 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
+
+
addfile ./FrontEnd/README.FrontEnd
hunk ./FrontEnd/README.FrontEnd 1
+
+much of the FrontEnd has been derived from other sources, such as the 'hatchet' type checking tool.
+various documents from the original sources follow. 
+
+Most files contain modifications by John Meacham (c) 2003-2005
+
+I have made little effort to keep track of the changes from the original
+hatchet source. but there are many, some drastic, others subtle.
+
+some changes include:
+
+got rid of AnnotatedHsSyn. uses HsSyn all the way through.
+handles recursive modules
+fixed renaming, seperated type and term namespaces
+fixed parser to not need HsParsePostProcess pass
+utilized record syntax.
+typechecks instance and class decls now
+keeps type variables around.
+annotates every use of a variable or data constructor with the type is was instantiated with
+lifts instance declarations to their own functions 
+records the type of every variable, pattern, useage of a variable, wildcard match etc. for direct conversion to a TIL.
+much more efficient, makes about 2 passes over the syntax rather than 5.
+got rid of TidyModule, it didn't help much and just generated lots of garbage during conversion.
+used DrIFT when appropriate.
+suport hierchical module names
+monadified parser and lexer using code from the latest Language.Haskell.ParserMonad
+added support for record syntax and record desugaring 
+added location info to ambiguity and context reduction errors
+
+
+Hatchet License:
+
+Hatchet version 0.1 is derived from a number of sources 
+each with their own Copyright and License restrictions. 
+See each file for the respective Copyright and
+License information.
+
+Special License and Copyright information for all work
+derived directly and indirectly from "Typing Haskell
+in Haskell" by Mark Jones (http://www.cse.ogi.edu/~mpj/thih/)
+is provided in the file "License.thih". Please read 
+that file carefully and abide by its contents.
+
+Hatchet is free software. Permission is granted to
+all good lifeforms and machines to use and distribute 
+it in whole or part, as source or binary, modified or 
+unmodified, for any purpose providing the Licenses 
+and Copyrights of the component sources are also 
+respected and followed.
+
+No warranty for any aspect of this software is 
+provided, neither explicitly nor implicitly,
+by anyone anywhere anyhow at any time past, present
+or future.
+
+THIH License:
+
+`Typing Haskell in Haskell' is Copyright (c) Mark P Jones,
+and the Oregon Graduate Institute of Science and Technology,
+October 1999, All rights reserved, and is distributed as
+free software under the following license.
+
+Redistribution and use in source and binary forms, with or
+without modification, are permitted provided that the following
+conditions are met:
+
+- Redistributions of source code must retain the above copyright
+notice, this list of conditions and the following disclaimer.
+
+- Redistributions in binary form must reproduce the above
+copyright notice, this list of conditions and the following
+disclaimer in the documentation and/or other materials provided
+with the distribution.
+
+- Neither name of the copyright holders nor the names of its
+contributors may be used to endorse or promote products derived
+from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+
+Hatchet Contributors:
+
+The following people have contributed to Hatchet:
+-------------------------------------------------
+
+Bernie Pope             (bjpop@cs.mu.oz.au)
+Bryn Humberstone
+Toby Ord
+Lindsay Powles
+Robert Shelton
+
+Hatchet has derived benefit from the work of many others including:
+-------------------------------------------------------------------
+
+Mark Jones         (Typing Haskell in Haskell)
+Manuel Chakravarty (FiniteMaps)
+Sven Panne         (GetOpt)
+Graham Hutton      (ParseLib)
+Erik Meijer        (ParseLib)
+The GHC team       (Digraph, Haskell Parsing and Pretty Printing)
+
+
+
+Thankyou to all those involved.
addfile ./FrontEnd/Rename.hs
hunk ./FrontEnd/Rename.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              The Hatchet Team (see file Contributors)
+
+        Module:                 Rename
+
+        Description:            Renames variables apart in a Module
+
+        Primary Authors:        Toby Ord, Bryn Humberstone, Bernie Pope
+
+        Notes:                  See the file License for license information
+
+-------------------------------------------------------------------------------}
+
+{-------------------------------------------------------------------------------
+
+  Major changes by John, many comments probably invalid.
+  This also desugars records
+
+  Implementation:
+
+
+     The algorithm then proceeds through the syntax tree, from outermost scope
+     to innermost in a depth first manner.
+
+     On entering a new scope, updateSubTableWith* is used to get the new names
+     in this scope, putting them into the current subTable, clobbering any
+     identifiers with the same name in outer scopes. It also creates their new
+     names (although no renaming is performed yet)
+
+     Now, all identifiers the algorithm finds before entering the next nested
+     scope will have a mapping to a new name in the subTable and their old
+     names get replaced by these
+     
+
+  * bugs
+
+     It should work for records but it doesn't rename them because it never adds
+     them to the scope
+
+     It also needs more testing for records
+
+     It assumes that all PatBinds have only one identifier to the left of the equals
+     ie. x     = a b c d   is OK
+         (x,y) = a b c d   is not
+     this should not be too hard to change
+
+     It doesn't add information about the identifiers in class and instance
+     definitions to the identTable.
+
+        - The correct behaviour here is not obvious as these are the only
+          identifiers that are declared multiple times, so there is no unique
+          source location.
+        - The method of declaration is also different to normal as identifiers
+          are normally added to the identTable when they are first added to the
+          scope, but these are added in the class
+          pass and can't be re-added.
+
+     It doesn't rename type signatures that do not have an associated PatBind
+     or FunBind
+
+-------------------------------------------------------------------------------}
+
+module FrontEnd.Rename(unRename, collectDefsHsModule, renameModule, FieldMap ) where 
+
+import Char        
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.FiniteMap
+import Data.Monoid
+import Doc.DocLike(tupled)
+import FrontEnd.Desugar (doToExp)
+import GenUtil hiding(replicateM)
+import HsErrors
+import HsSyn hiding(srcLoc)
+import List
+import MonadUtil
+import MonoidUtil
+import Name hiding(qualifyName)
+import qualified Data.Map as Map
+import Utils     
+import VConsts hiding(func_fromInt, func_fromInteger, func_fromRational)
+import Warning
+
+
+type FieldMap =  (Map.Map Name Int,Map.Map Name [(Name,Int)])
+
+--------------------------------------------------------------------------------
+
+--instance (Show a, Show b) => Show (FiniteMap a b) where
+--    show fm = show (fmToList fm)
+
+
+-- 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 = FiniteMap 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 {  
+    currentModule  :: Module,
+    unique         :: !Int,
+    globalSubTable :: FiniteMap HsName HsName,  -- Current substition
+    typeSubTable   :: FiniteMap HsName HsName,  -- type substition table
+    errorTable     :: FiniteMap HsName String,  -- special error message. else it's just unknown.
+    nameMap        :: Map.Map Name (Either String Name),
+    fieldLabels    :: FieldMap,
+    errors         :: [Warning],
+    srcLoc         :: !SrcLoc
+    } 
+
+
+-- The monadic type
+type ScopeSM = State ScopeState 
+runScopeSM s0 a = runState a s0
+
+instance MonadWarn ScopeSM where
+    addWarning w = modify (\s -> s { errors = w: errors s})
+
+
+
+getUnique :: ScopeSM Int 
+getUnique = gets unique
+
+getCurrentModule :: ScopeSM Module
+getCurrentModule = gets currentModule
+
+getGlobalSubTable :: ScopeSM SubTable
+getGlobalSubTable = gets globalSubTable
+
+setSrcLoc e = modify (\s -> s { srcLoc =  e `mappend` srcLoc s }) 
+
+-- functions to modify the ScopeSM
+
+incUnique :: ScopeSM ()
+incUnique = modify (\state -> state {unique = (unique state) + 1})
+
+
+-----------------------------------------------------------
+-- The renaming code:
+--
+
+
+addTopLevels ::  [HsDecl]  -> ScopeSM ()
+addTopLevels  []  = return ()
+addTopLevels  hsDecls = do
+    mod <- getCurrentModule
+    let (ns,ts) = mconcat (map namesHsDecl hsDecls)
+        nm = listToFM $ foldl f [] (fsts ns)
+        tm = listToFM $ foldl f [] (fsts ts)
+        f r hsName@Qual {} 
+            | Just _ <- fromTupname hsName, Module "Prelude" <- mod 
+                = let nn = hsName in (nn,nn):r 
+            | otherwise = error $ "strong bad: " ++ fromHsName 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" (fromHsName n ++ " is defined multiple times: " ++ show xs ) 
+    z ns >> z ts
+    modify (\s -> s { globalSubTable = nm `plusFM` globalSubTable s }) 
+    modify (\s -> s { typeSubTable = tm `plusFM` typeSubTable s }) 
+    return ()
+ 
+ {-
+collectRenameHsSyns ::  SubTable -> [HsDecl] -> ScopeSM [HsDecl]
+collectRenameHsSyns sub (d@(HsTypeDecl sl name args ty):ds) = liftM2 (:) (renameHsTypeDecl sub sl name args ty) (collectRenameHsSyns sub ds)
+collectRenameHsSyns sub (_:ds) = (collectRenameHsSyns sub ds)
+collectRenameHsSyns sub [] = []
+
+renameHsTypeDecl sub sl name args ty = do
+    setSrcLoc sl
+    hsName' <- renameHsName name subTable
+    subTable' <- updateSubTableWithHsNames subTable hsNames
+    hsNames' <- renameHsNames hsNames subTable'
+    t' <- renameHsType t subTable'
+    return (HsTypeDecl srcLoc  hsName' hsNames' t')
+-}    
+
+
+ambig x ys = "Ambiguous Name: " ++ show x ++ "\nCould refer to: " ++ tupled (map show ys)
+
+-- | Main entry point.
+
+renameModule :: MonadWarn m => FieldMap -> [(Name,[Name])] -> HsModule -> m HsModule
+renameModule fls ns m = mapM_ addWarning (errors finalState) >> return renamedMod where
+    initialGlobalSubTable = listToFM [ (x,y) | ((typ,x),[y]) <- ns', typ == Val || typ == DataConstructor ]
+    initialTypeSubTable = listToFM [ (x,y) | ((typ,x),[y]) <- ns', typ == TypeConstructor || typ == ClassName ]
+    ns' = map fn ns
+    fn (n,ns) = (fromName n, map nameName ns)
+
+    errorTab =  listToFM [ (x,ambig x ys) | ((typ,x),ys@(_:_:_)) <- ns' ]
+
+    startState = ScopeState { 
+        typeSubTable   = initialTypeSubTable,
+        errorTable     = errorTab,
+        nameMap        = Map.empty,
+        errors         = [],
+        srcLoc         = mempty,
+        unique         = 1,   -- start the counting at 1
+        globalSubTable = initialGlobalSubTable,
+        fieldLabels    = fls,
+        currentModule  = hsModuleName m
+        }
+
+    (renamedMod, finalState) = runScopeSM startState (renameDecls m initialGlobalSubTable) 
+
+{-
+-- takes a list of qualified HsNames that the current module needs to know
+-- about (i.e. ones imported from Prelude), and then in the renaming process
+-- any of those names appearing in unqualified form will get qualified
+-- e.g. we pass in [Qual (Module "Prelude") "take"] and then in code we see
+-- foo = take 3 [1..10], so we translate this to (something like)
+-- Main.foo = Prelude.take 3 [1..10]
+renameTidyModule :: [HsDecl] -> [HsName] -> [HsName] -> HsModule -> (HsModule, [Warning])
+renameTidyModule syns importedNames impTypeNames tidyMod 
+    = mapSnd errors z {- (renamedTidyMod, errors finalState) -} where
+    initialGlobalSubTable :: SubTable
+    initialGlobalSubTable = listToFM (map makeTranslation importedNames)
+    initialTypeSubTable = listToFM (map makeTranslation impTypeNames)
+    makeTranslation qname@(Qual _ str) = (UnQual str, qname)
+    makeTranslation unqname = error $ "renameTidyModule passed an unqualified importedName " ++ show unqname
+
+    startState = ScopeState { 
+        typeSubTable   = initialTypeSubTable,
+        errorTable     = emptyFM,
+        errors         = [],
+        synonyms       = syns,
+        srcLoc         = bogusASrcLoc,
+        unique         = 1,   -- start the counting at 1
+        globalSubTable = initialGlobalSubTable,
+        currentModule  = hsModuleName tidyMod 
+        }
+
+    z@(renamedTidyMod, finalState) = runScopeSM startState (renameDecls tidyMod initialGlobalSubTable) 
+-}
+
+-- 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 -> SubTable -> ScopeSM HsModule
+renameDecls tidy subTable = do
+        addTopLevels $ hsModuleDecls tidy
+        subTable'a <- gets globalSubTable
+        let subTable' = subTable `plusFM` subTable'a 
+        --addError (show $ fmToList subTable')
+        decls' <-  renameHsDecls (hsModuleDecls tidy) subTable' ; return decls'
+        --addDiag (show syns) 
+        --sta <- gets globalSubTable
+        --stb <- gets typeSubTable
+        --addDiag (show (sta, stb)) 
+        return tidy { hsModuleDecls = decls' }
+     
+
+-- The following functions all take a piece of the Haskell syntax tree
+-- (as outlined in HsSyn) and uses the provided SubTable to rename it
+
+-- Some of the functions have to create a new nested scope which they do
+-- by creating a new SubTable using updateSubTableWith* and passing that
+-- new table down to its children on the syntax tree.
+
+renameHsDecls :: [HsDecl] -> SubTable -> ScopeSM ([HsDecl])
+renameHsDecls decls subtable = do 
+    ans <- mapRename renameHsDecl (expandTypeSigs decls) subtable
+    mapM_ HsErrors.hsDecl ans
+    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 = do
+    setSrcLoc srcLoc
+    hsPat'    <- renameHsPat hsPat subTable
+    subTable' <- updateSubTableWithHsDecls subTable hsDecls LetFun
+    hsDecls'  <- renameHsDecls hsDecls subTable'
+    hsRhs'    <- renameHsRhs hsRhs subTable'
+    let patbind' = (HsPatBind srcLoc hsPat' hsRhs' {-where-} hsDecls')
+    return patbind'
+      
+renameHsDecl (HsForeignDecl a b c n t) subTable = do
+    setSrcLoc a
+    n <- renameHsName n subTable
+    subTable' <- updateSubTableWithHsQualType subTable t
+    --addDiag $ show (n, "foreigna",t)
+    t <- renameHsQualType t subTable'
+    --addDiag $ show (n, "foreignb",t)
+    return  (HsForeignDecl a b c n t)
+
+--renameHsDecl (HsFunBind srcLoc hsMatches) subTable
+renameHsDecl (HsFunBind hsMatches) subTable = do
+    hsMatches' <- renameHsMatches hsMatches subTable
+    -- return (HsFunBind srcLoc hsMatches')
+    return (HsFunBind hsMatches')
+
+renameHsDecl (HsTypeSig srcLoc hsNames hsQualType) subTable = do
+    setSrcLoc srcLoc
+    hsNames' <- renameHsNames hsNames subTable
+    subTable' <- updateSubTableWithHsQualType subTable hsQualType
+    hsQualType' <- renameHsQualType hsQualType subTable'
+    return (HsTypeSig srcLoc hsNames' hsQualType')
+renameHsDecl (HsDataDecl srcLoc hsContext hsName hsNames1 hsConDecls hsNames2) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameTypeHsName hsName subTable
+    subTable' <- updateSubTableWithHsNames subTable hsNames1
+    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
+    hsNames2' <- mapM (`renameTypeHsName` subTable') hsNames2
+    return (HsDataDecl srcLoc hsContext' hsName' hsNames1' hsConDecls' hsNames2')
+renameHsDecl (HsTypeDecl srcLoc name hsNames t) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameTypeHsName name subTable
+    --subTable' <- updateSubTableWithHsNames subTable hsNames
+    --hsNames' <- renameHsNames hsNames subTable'
+    t' <- renameHsType' False t emptyFM
+    return (HsTypeDecl srcLoc  hsName' hsNames t')
+
+renameHsDecl (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameTypeHsName hsName subTable
+    subTable' <- updateSubTableWithHsNames subTable hsNames1
+    hsContext' <- renameHsContext hsContext subTable'
+    hsNames1' <- renameHsNames hsNames1 subTable'
+    hsConDecl' <- renameHsConDecl hsConDecl subTable'
+    -- don't need to rename the hsNames2 as it is just a list of TypeClasses
+    hsNames2' <- mapM (`renameTypeHsName` subTable') hsNames2
+    return (HsNewTypeDecl srcLoc hsContext' hsName' hsNames1' hsConDecl' hsNames2')
+--renameHsDecl (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) subTable = do
+--    setSrcLoc srcLoc
+--    subTable' <- updateSubTableWithHsNames subTable hsNames1
+--    hsContext' <- renameHsContext hsContext subTable'
+--    -- don't need to rename the hsName (it is a constructor)
+--    hsNames1' <- renameHsNames hsNames1 subTable'
+--    hsConDecl' <- renameHsConDecl hsConDecl subTable'
+--    -- don't need to rename the hsNames2 as it is just a list of TypeClasses
+--    hsNames2' <- mapM (`renameTypeHsName` subTable') hsNames2
+--    return (HsNewTypeDecl srcLoc hsContext' hsName hsNames1' hsConDecl' hsNames2')
+-- here, we have to create a separate subTable (called the typeSigSubTable) to be passed down
+-- because the part that renames the hsQualType in the type signatures needs a subTable with
+-- _only_ the class's QualType in it.
+-- Yes this is complicated and nasty. It is due mainly to the fact that some (but not all of
+-- the type variables in the type sigs of the class's member functions must be renamed and
+-- the new variables are used on the fly and not declared in an orderly manner.
+renameHsDecl (HsClassDecl srcLoc hsQualType hsDecls) subTable = do
+    setSrcLoc srcLoc
+    startingSubTable <- return subTable
+    {- WAS: typeSigSubTable <- updateSubTableWithHsQualType initialSubTable hsQualType -}
+    typeSigSubTable <- updateSubTableWithHsQualType startingSubTable hsQualType 
+    hsQualType' <- renameHsQualType hsQualType typeSigSubTable
+    hsDecls' <- renameHsDecls hsDecls subTable
+    return (HsClassDecl srcLoc hsQualType' hsDecls')
+renameHsDecl (HsInstDecl srcLoc hsQualType hsDecls) subTable = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsQualType subTable hsQualType
+    hsQualType' <- renameHsQualType hsQualType subTable'
+    hsDecls' <- renameHsDecls hsDecls subTable'
+    return (HsInstDecl srcLoc hsQualType' hsDecls')
+renameHsDecl (HsInfixDecl srcLoc assoc int hsNames) subTable = do
+    setSrcLoc srcLoc
+    -- can't do this as we might already have an import
+    hsNames' <- renameHsNames hsNames subTable
+    -- we really just want to qualify the names with the
+    -- current module
+    {-
+    modName <- getCurrentModule 
+    let hsNames' = map (Utils.qualifyName modName) hsNames
+    -}
+    return $ HsInfixDecl srcLoc assoc int hsNames'
+renameHsDecl (HsPragmaProps srcLoc prop hsNames) subTable = do
+    setSrcLoc srcLoc
+    hsNames' <- renameHsNames hsNames subTable
+    return (HsPragmaProps  srcLoc prop hsNames')
+
+renameHsDecl otherHsDecl _ = return otherHsDecl
+
+
+
+
+renameHsQualType :: HsQualType -> SubTable -> ScopeSM (HsQualType)
+renameHsQualType (HsQualType hsContext hsType) subTable = do
+      hsContext' <- renameHsContext hsContext subTable
+      hsType' <- renameHsType hsType subTable
+      return (HsQualType hsContext' hsType')
+renameHsQualType (HsUnQualType hsType) subTable = do
+      hsType' <- renameHsType hsType subTable
+      return (HsQualType [] hsType')
+
+renameHsContext :: HsContext -> SubTable -> ScopeSM (HsContext)
+renameHsContext = mapRename renameHsAsst
+
+renameHsAsst :: HsAsst -> SubTable -> ScopeSM (HsAsst)
+renameHsAsst (hsName1, hsName2) subTable = do
+      hsName1' <- renameTypeHsName hsName1 subTable  -- for class names
+      hsName2' <- renameTypeHsName hsName2 subTable
+      return (hsName1', hsName2')
+
+renameHsConDecls :: [HsConDecl] -> SubTable -> ScopeSM ([HsConDecl])
+renameHsConDecls = mapRename renameHsConDecl
+
+renameHsConDecl :: HsConDecl -> SubTable -> ScopeSM (HsConDecl)
+renameHsConDecl (HsConDecl srcLoc hsName hsBangTypes) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameHsName hsName subTable
+    hsBangTypes' <- renameHsBangTypes hsBangTypes subTable
+    return (HsConDecl srcLoc hsName' hsBangTypes') 
+renameHsConDecl (HsRecDecl srcLoc hsName stuff) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameHsName hsName subTable
+    stuff' <- sequence [ do ns' <- mapRename renameHsName ns subTable; t' <- renameHsBangType t subTable; return (ns',t')  |  (ns,t) <- stuff]
+    return (HsRecDecl srcLoc hsName' 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 t st = do 
+    t <- renameHsType' True t st
+    HsErrors.hsType t
+    return t
+
+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 (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
+        False <- return dovar
+        v <- renameHsQualType v subTable
+        return $ HsTyForall ts v
+    pp t | not dovar = t
+    pp t = t
+--    pp t = do
+--        t' <- t
+--        syns <- gets synonyms
+        --addDiag $ show ("pp", t')
+        --return t'
+--        return (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 = do
+    setSrcLoc srcLoc
+    hsName' <- renameHsName hsName subTable
+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc FunPat
+    hsPats' <- renameHsPats hsPats subTable'
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls WhereFun
+    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 (HsPVar hsName) subTable = do
+      hsName' <- renameHsName hsName subTable
+      return (HsPVar hsName')
+renameHsPat (HsPLit hsLiteral) _subTable
+  = return (HsPLit hsLiteral)
+renameHsPat (HsPNeg hsPat) subTable = do
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPNeg hsPat')
+renameHsPat (HsPInfixApp hsPat1 hsName hsPat2) subTable = do
+      hsPat1' <- renameHsPat hsPat1 subTable
+      hsPat2' <- renameHsPat hsPat2 subTable
+      hsName' <- renameHsName hsName subTable
+      return (HsPInfixApp hsPat1' hsName' hsPat2')
+renameHsPat (HsPApp hsName hsPats) subTable = do
+      hsPats' <- renameHsPats hsPats subTable
+      hsName' <- renameHsName hsName subTable
+      return (HsPApp hsName' hsPats')  -- NOTE: Bryn changed this so we also rename hsName and not just the hsPats
+renameHsPat (HsPTuple hsPats) subTable = do
+      hsPats' <- renameHsPats hsPats subTable
+      return (HsPTuple hsPats')
+renameHsPat (HsPList hsPats) subTable = do
+      hsPats' <- renameHsPats hsPats subTable
+      return (HsPList hsPats')
+renameHsPat (HsPParen hsPat) subTable = do
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPParen hsPat')
+renameHsPat (HsPRec hsName hsPatFields) subTable = do
+      hsName' <- renameHsName hsName subTable
+      hsPatFields' <- renameHsPatFields hsPatFields subTable
+      fls <- gets fieldLabels
+      buildRecPat fls hsName' hsPatFields'
+  --    return (HsPRec hsName hsPatFields)
+renameHsPat (HsPAsPat hsName hsPat) subTable = do
+      hsName' <- renameHsName hsName subTable
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPAsPat hsName' hsPat')
+renameHsPat HsPWildCard subTable = do
+      unique <- getUnique
+      incUnique
+      mod <- getCurrentModule
+      let hsName' = Qual mod (HsIdent $ show unique ++ "_wild@")
+      return (HsPVar hsName')
+--renameHsPat (HsPWildCard) _subTable
+--  = return HsPWildCard
+renameHsPat (HsPIrrPat hsPat) subTable = do
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPIrrPat hsPat')
+
+buildRecPat :: FieldMap -> HsName -> [HsPatField] -> ScopeSM 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
+
+renameHsPatFields :: [HsPatField] -> SubTable -> ScopeSM ([HsPatField])
+renameHsPatFields = mapRename renameHsPatField
+
+-- although the hsNames here must be unique (field names),
+-- I rename them for the sake of completeness
+renameHsPatField :: HsPatField -> SubTable -> ScopeSM (HsPatField)
+{-
+renameHsPatField (HsPFieldPun hsName) subTable
+  = do
+      hsName' <- renameHsName hsName subTable
+      return (HsPFieldPun hsName')
+-}
+renameHsPatField (HsPFieldPat hsName hsPat) subTable = do
+    gt <- gets globalSubTable      -- field names are not shadowed by local definitions.
+    hsName' <- renameHsName hsName gt
+    hsPat' <- renameHsPat hsPat subTable
+    return (HsPFieldPat hsName' hsPat')
+
+
+renameHsRhs :: HsRhs -> SubTable -> ScopeSM HsRhs
+renameHsRhs (HsUnGuardedRhs hsExp) subTable
+  = do
+      hsExp' <- renameHsExp hsExp subTable
+      return (HsUnGuardedRhs hsExp')
+renameHsRhs (HsGuardedRhss hsGuardedRhss) subTable
+  = do
+      hsGuardedRhss' <- renameHsGuardedRhss hsGuardedRhss subTable
+      return (HsGuardedRhss hsGuardedRhss')
+
+
+renameHsGuardedRhss :: [HsGuardedRhs] -> SubTable -> ScopeSM ([HsGuardedRhs])
+renameHsGuardedRhss = mapRename renameHsGuardedRhs
+
+renameHsGuardedRhs :: HsGuardedRhs -> SubTable -> ScopeSM HsGuardedRhs
+renameHsGuardedRhs (HsGuardedRhs srcLoc hsExp1 hsExp2) subTable = do
+    setSrcLoc srcLoc
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsGuardedRhs srcLoc hsExp1' hsExp2')
+
+
+renameHsExps :: [HsExp] -> SubTable -> ScopeSM ([HsExp])
+renameHsExps = mapRename renameHsExp
+
+func_fromInt = (HsVar (hsUnqualValName "fromInt"))
+func_fromInteger = (HsVar (hsUnqualValName "fromInteger"))
+func_fromRational = (HsVar (hsUnqualValName "fromRational"))
+
+newVar = do
+    unique <- getUnique
+    incUnique
+    mod <- getCurrentModule
+    let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_var@"))
+    return hsName''
+
+wrapInAsPat e = do
+    unique <- getUnique
+    incUnique
+    mod <- getCurrentModule
+    let hsName'' = (Qual mod (HsIdent $ show unique {- ++ fromHsName hsName' -} ++ "_as@"))
+    return (HsAsPat hsName''  e )
+
+
+renameHsExp :: HsExp -> SubTable -> ScopeSM HsExp
+renameHsExp (HsVar hsName) subTable = do
+    hsName' <- renameHsName hsName subTable
+    wrapInAsPat (HsVar hsName')
+--    unique <- getUnique
+--    incUnique
+--    mod <- getCurrentModule
+--    let hsName'' = (Qual mod (HsIdent $ show unique ++ fromHsName hsName' ++ "_as@"))
+--    return (HsAsPat hsName'' $   HsVar hsName' )
+renameHsExp (HsCon hsName) subTable = do
+    hsName' <- renameHsName hsName subTable
+    wrapInAsPat (HsCon hsName')
+--    unique <- getUnique
+--    incUnique
+--    mod <- getCurrentModule
+--    let hsName'' = (Qual mod (HsIdent $ show unique ++ fromHsName hsName' ++ "_as@"))
+--    return (HsAsPat hsName'' $ HsCon hsName') 
+
+renameHsExp i@(HsLit (HsInt num)) st = do
+    let fi = if abs num > 500000000 then func_fromInteger else func_fromInt
+    z <- renameHsExp fi st
+    --ic <- renameHsExp (HsCon (UnQual (HsIdent "Integer"))) st
+    return $ HsParen (HsApp z i)
+renameHsExp i@(HsLit (HsFrac _)) st = do
+    z <- renameHsExp func_fromRational st
+    --ic <- renameHsExp (HsCon (UnQual (HsIdent "Integer"))) st
+    return $ HsParen (HsApp z i)
+renameHsExp (HsLit hsLiteral) _subTable = do
+    return (HsLit hsLiteral)
+renameHsExp (HsInfixApp hsExp1 hsExp2 hsExp3) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    hsExp3' <- renameHsExp hsExp3 subTable
+    return (HsInfixApp hsExp1' hsExp2' hsExp3')
+renameHsExp (HsApp hsExp1 hsExp2) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsApp hsExp1' hsExp2')
+renameHsExp (HsNegApp hsExp) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsNegApp hsExp')
+renameHsExp (HsLambda srcLoc hsPats hsExp) subTable = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc LamPat
+    hsPats' <- renameHsPats hsPats subTable'
+    hsExp' <- renameHsExp hsExp subTable'
+    return (HsLambda srcLoc hsPats' hsExp')
+renameHsExp (HsLet hsDecls hsExp) subTable = do
+    subTable' <- updateSubTableWithHsDecls subTable hsDecls LetFun
+    hsDecls' <- renameHsDecls hsDecls subTable'
+    hsExp' <- renameHsExp hsExp subTable'
+    return (HsLet hsDecls' hsExp')
+renameHsExp (HsIf hsExp1 hsExp2 hsExp3) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    hsExp3' <- renameHsExp hsExp3 subTable
+    return (HsIf hsExp1' hsExp2' hsExp3')
+renameHsExp (HsCase hsExp hsAlts) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    hsAlts' <- renameHsAlts hsAlts subTable
+    return (HsCase hsExp' hsAlts')
+renameHsExp (HsDo hsStmts) subTable = do
+    let e = doToExp hsStmts
+    renameHsExp e subTable
+    --(hsStmts',_) <- renameHsStmts hsStmts subTable
+    --return (doToExp hsStmts')
+renameHsExp (HsTuple hsExps) subTable = do
+    hsExps' <- renameHsExps hsExps subTable
+    return (HsTuple hsExps')
+renameHsExp (HsList hsExps) subTable = do
+    unique <- getUnique
+    incUnique
+    hsExps' <- renameHsExps hsExps subTable
+    mod <- getCurrentModule
+    let hsName' = Qual mod (HsIdent $ show unique ++ "_as@")
+    return (HsAsPat hsName' $ HsList hsExps')
+renameHsExp (HsParen hsExp) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    return (hsParen hsExp')
+renameHsExp (HsLeftSection hsExp1 hsExp2) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsLeftSection hsExp1' hsExp2')
+renameHsExp (HsRightSection hsExp1 hsExp2) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsRightSection hsExp1' hsExp2')
+-- XXX I'm not 100% sure that this bit works.
+renameHsExp (HsRecConstr hsName hsFieldUpdates) subTable = do
+    hsName' <- renameHsName hsName subTable  -- do I need to change this name?
+    hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates subTable
+    fls <- gets fieldLabels 
+    buildRecConstr fls (hsName':: HsName) (hsFieldUpdates'::[HsFieldUpdate]) -- HsRecConstr hsName' hsFieldUpdates')
+renameHsExp (HsRecUpdate hsExp hsFieldUpdates) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    hsFieldUpdates' <- renameHsFieldUpdates hsFieldUpdates subTable
+    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 (HsEnumFrom hsExp')
+    return ( hsExp')
+renameHsExp (HsEnumFromTo hsExp1 hsExp2) subTable = do
+    let x = desugarEnum "enumFromTo" [hsExp1, hsExp2]
+    hsExp' <- renameHsExp x subTable
+    return ( hsExp')
+    --hsExp' <- renameHsExp x subTable
+    --hsExp1' <- renameHsExp hsExp1 subTable
+    --hsExp2' <- renameHsExp hsExp2 subTable
+    --return (HsEnumFromTo hsExp1' hsExp2')
+renameHsExp (HsEnumFromThen hsExp1 hsExp2) subTable = do
+    let x = desugarEnum "enumFromThen" [hsExp1, hsExp2]
+    hsExp' <- renameHsExp x subTable
+    return ( hsExp')
+    --hsExp1' <- renameHsExp hsExp1 subTable
+    --hsExp2' <- renameHsExp hsExp2 subTable
+    --return (HsEnumFromThen hsExp1' hsExp2')
+renameHsExp (HsEnumFromThenTo hsExp1 hsExp2 hsExp3) subTable = do
+    let x = desugarEnum "enumFromThenTo" [hsExp1, hsExp2, hsExp3]
+    hsExp' <- renameHsExp x subTable
+    return ( hsExp')
+    --hsExp1' <- renameHsExp hsExp1 subTable
+    --hsExp2' <- renameHsExp hsExp2 subTable
+    --hsExp3' <- renameHsExp hsExp3 subTable
+    --return (HsEnumFromThenTo hsExp1' hsExp2' hsExp3')
+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 (HsAsPat hsName hsExp) subTable = do
+    hsName' <- renameHsName hsName subTable
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsAsPat hsName' hsExp')
+renameHsExp (HsWildCard sl) _ = do 
+    setSrcLoc sl
+    e <- createError ("_")
+    return e
+renameHsExp (HsIrrPat hsExp) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsIrrPat hsExp')
+
+desugarEnum s as = foldl HsApp (HsVar (hsUnqualValName s)) as
+
+
+createError s = do
+    sl <- gets srcLoc
+    pe <- wrapInAsPat (HsVar (hsValName ("Prelude","error")))
+    return $ HsParen $ HsApp pe (HsLit (HsString (show sl ++ ": " ++ s)))
+
+failRename s = do
+    sl <- gets srcLoc
+    fail (show sl ++ ": " ++ s)
+    
+
+buildRecConstr ::  FieldMap -> HsName -> [HsFieldUpdate] -> ScopeSM HsExp
+buildRecConstr (amp,fls) n us = do
+    undef <- createError "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] -> ScopeSM HsExp
+buildRecUpdate (amp,fls) n us = do
+        sl <- gets srcLoc
+        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
+                    vars' <- mapM wrapInAsPat (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))  (HsUnGuardedAlt x) []
+        as <- mapM g fm'
+        pe <- createError "Record Update Error"
+        v <- newVar
+        return $ HsCase n (as ++ [HsAlt sl (HsPVar v) (HsUnGuardedAlt pe) []]) 
+--    undef <- createError "Uninitialized Field"
+--    case Map.lookup (toName DataConstructor n) amp of
+--        Nothing -> failRename $ "Unknown Constructor: " ++ show n 
+--        Just t -> do 
+
+--buildRecUpdate ::  FieldMap -> HsExp -> [HsFieldUpdate] -> ScopeSM HsExp
+--buildRecUpdate _ _ _ = failRename "Can't handle field updates just yet."
+
+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 = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsPats subTable [hsPat] srcLoc CasePat
+    hsPat' <- renameHsPat hsPat subTable'
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls WhereFun
+    hsDecls' <- renameHsDecls hsDecls subTable''
+    hsGuardedAlts' <- renameHsGuardedAlts hsGuardedAlts subTable''
+    return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')
+
+renameHsGuardedAlts :: HsGuardedAlts -> SubTable -> ScopeSM (HsGuardedAlts)
+renameHsGuardedAlts (HsUnGuardedAlt hsExp) subTable = do
+      hsExp' <- renameHsExp hsExp subTable
+      return (HsUnGuardedAlt hsExp')
+renameHsGuardedAlts (HsGuardedAlts hsGuardedAltList) subTable = do
+      hsGuardedAltList' <- renameHsGuardedAltList hsGuardedAltList subTable
+      return (HsGuardedAlts hsGuardedAltList')
+
+renameHsGuardedAltList :: [HsGuardedAlt] -> SubTable -> ScopeSM [HsGuardedAlt]
+renameHsGuardedAltList = mapRename renameHsGuardedAlt
+
+renameHsGuardedAlt :: HsGuardedAlt -> SubTable -> ScopeSM HsGuardedAlt
+renameHsGuardedAlt (HsGuardedAlt srcLoc hsExp1 hsExp2) subTable = do
+    setSrcLoc srcLoc
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsGuardedAlt 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
+    gt <- gets globalSubTable     -- field names are global and not shadowed
+    hsName' <- renameHsName hsName gt      -- TODO field names should have own namespace
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsFieldUpdate hsName' hsExp')
+
+
+renameHsNames :: [HsName] -> SubTable -> ScopeSM ([HsName])
+renameHsNames = mapRename renameHsName 
+
+-- 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 subTable 
+    | Qual (Module ('@':m)) (HsIdent i) <- hsName = return $ Qual (Module m) (HsIdent i)
+renameHsName hsName subTable = case lookupFM subTable  hsName of
+    Just name@(Qual _ _) -> return name
+    Just _ -> error "renameHsName"
+    Nothing
+        | Just n <- fromTupname hsName -> return hsName
+        | otherwise -> do 
+            sl <- gets srcLoc
+            et <- gets errorTable
+            let err = case lookupFM et hsName of {
+                Just s -> s;
+                Nothing -> "Unknown name: " ++ fromHsName hsName }
+            warn sl "undefined-name" err
+            -- e <- createError ("Undefined Name: " ++ show hsName)
+            return $ hsName
+            --return (Qual modName name)
+
+
+--renameTypeHsName hsName subTable  = case hsIdentString (hsNameIdent hsName) of 
+--    xs@(x:_) | isUpper x -> do
+--        t <- gets typeSubTable
+--        renameHsName hsName t
+--    _ -> renameHsName hsName subTable
+    
+
+renameTypeHsName hsName subTable  =  gets typeSubTable  >>= \t -> case lookupFM t hsName of 
+    Just _ -> renameHsName hsName t
+    Nothing -> renameHsName hsName subTable
+
+---------------------------------------
+-- 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 -> Binding -> ScopeSM (SubTable)
+clobberHsNamesAndUpdateIdentTable ((hsName,srcLoc):hsNamesAndASrcLocs) subTable binding = do
+      subTable'  <- clobberHsName hsName subTable
+      subTable'' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable' binding
+      return (subTable'')
+clobberHsNamesAndUpdateIdentTable [] subTable _binding = 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
+  = do
+      unique     <- getUnique       
+      currModule <- getCurrentModule
+      let hsName'     = renameAndQualify hsName unique currModule
+          subTable'   = addToFM subTable hsName hsName'
+      incUnique
+      return (subTable')
+
+
+
+renameAndQualify :: HsName -> Int -> Module -> HsName
+renameAndQualify name unique currentMod
+    = case rename name unique of
+           UnQual name' -> Qual currentMod name'
+           qual_name    -> qual_name
+
+-- renames a haskell name with its unique number 
+rename :: HsName -> Int -> HsName
+rename 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 $ fromHsIdentifier 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
+
+
+updateSubTableWithHsDecls :: SubTable -> [HsDecl] -> Binding -> ScopeSM (SubTable)
+updateSubTableWithHsDecls subTable [] _binding = return subTable
+updateSubTableWithHsDecls subTable (hsDecl:hsDecls) binding = do
+    let hsNamesAndASrcLocs = getHsNamesAndASrcLocsFromHsDecl hsDecl
+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable binding
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls binding
+    return (subTable'')
+
+updateSubTableWithHsPats :: SubTable -> [HsPat] -> SrcLoc -> Binding -> ScopeSM (SubTable)
+updateSubTableWithHsPats subTable (hsPat:hsPats) srcLoc binding = do
+    let hsNamesAndASrcLocs = zip (getHsNamesFromHsPat hsPat) (repeat srcLoc)
+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable binding
+    subTable'' <- updateSubTableWithHsPats subTable' hsPats srcLoc binding
+    return subTable''
+updateSubTableWithHsPats subTable [] _srcLoc _binding = 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 GenPat
+    return (subTable')
+
+----------------------------------------------------------
+-- the following updateSubTableWith* functions do not need to alter the identTable aswell
+--
+
+
+-- takes a list of HsNames representing type variables in a data decl and
+-- adds them to the current subTable
+
+updateSubTableWithHsNames :: SubTable -> [HsName] -> ScopeSM (SubTable)
+updateSubTableWithHsNames subTable hsNames = do
+      subTable' <- clobberHsNames hsNames subTable
+      return (subTable')
+
+-- 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')
+
+
+
+-- takes a list of decls and examines only the class decls
+-- to get the names of variables used in their type sigs
+
+updateSubTableWithClasses :: SubTable -> [HsDecl] -> ScopeSM (SubTable)
+updateSubTableWithClasses subTable []
+  = return subTable
+updateSubTableWithClasses subTable (hsDecl:hsDecls)
+  = do
+      let hsNames = getHsNamesFromClass hsDecl
+      subTable'  <- clobberHsNames hsNames subTable
+      subTable'' <- updateSubTableWithClasses subTable' hsDecls 
+      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)]
+
+
+-- | 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 (HsFunBind [])  = return ()
+    f (HsFunBind (HsMatch a n _ _ _:_))  = tellF [(toName Val n,a,[])]
+    f (HsPatBind srcLoc p _ _) = tellF [ (toName Val n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
+    f (HsTypeDecl sl n _ _) = tellF [(toName TypeConstructor n,sl,[])]
+    f (HsDataDecl sl _ n _ 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 ClassName z,sl,snub $ fsts cs):[ (n,a,[]) | (n,a) <- cs]  where
+        Just z = maybeGetDeclName cd    
+        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' _ _ = ([],[])
+
+{-
+collectDefsHsModule :: HsModule -> [(Bool,HsName,SrcLoc,[HsName])]
+collectDefsHsModule m = map g $ snd $ runWriter (mapM_ f (hsModuleDecls m)) where
+    g (b,n,sl,ns) = (b,mod n, sl, map mod ns) 
+    mod = qualifyName (hsModuleName m)
+    f (HsForeignDecl a _ _ n _)  = tell [(False,n,a,[])]
+    f (HsFunBind [])  = return ()
+    f (HsFunBind (HsMatch a n _ _ _:_))  = tell [(False,n,a,[])]
+    f (HsPatBind srcLoc p _ _) = tell [ (False,n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
+    f (HsTypeDecl sl n _ _) = tell [(True,n,sl,[])]
+    f (HsDataDecl sl _ n _ cs _) = tell $ (True,n,sl,fsts cs'):[ (False,n,sl,[]) | (n,sl) <- cs'] where 
+        cs' = concatMap namesHsConDecl cs
+    f (HsNewTypeDecl sl _ n _ c _) =  tell $ (True,n,sl,fsts cs'):[ (False,n,sl,[]) | (n,sl) <- cs'] where 
+        cs' = namesHsConDecl c
+    f cd@(HsClassDecl sl _ ds) = tell $ (True,z,sl,fsts cs):[ (False,n,a,[]) | (n,a) <- cs]  where
+        Just z = maybeGetDeclName cd    
+        cs = fst (mconcatMap namesHsDeclTS ds)
+    f _ = return ()
+
+-- | Collect all names which are defined in a given module.
+namesHsModule :: 
+    HsModule   -- ^ Module to collect names from.
+    -> ([(HsName, SrcLoc)],[(HsName, SrcLoc)])  -- ^ (value-like names,type-like names)
+namesHsModule m = mconcatMap namesHsDecl (hsModuleDecls m)
+-}
+
+namesHsDecl :: HsDecl -> ([(HsName, SrcLoc)],[(HsName, SrcLoc)])
+namesHsDecl (HsForeignDecl a _ _ n _)  = ([(n,a)],[])
+namesHsDecl (HsFunBind hsMatches)  = (getHsNamesAndASrcLocsFromHsMatches hsMatches, [])
+namesHsDecl (HsPatBind srcLoc p _ _) = (map (rtup srcLoc) (getHsNamesFromHsPat p),[])
+namesHsDecl (HsTypeDecl sl n _ _) = ([],[(n,sl)])
+namesHsDecl (HsDataDecl sl _ n _ cs _) = ( (concatMap namesHsConDecl cs) ,[(n,sl)])
+namesHsDecl (HsNewTypeDecl sl _ n _ c _) = ( (namesHsConDecl c),[(n,sl)])
+namesHsDecl cd@(HsClassDecl sl _ ds) = (mconcatMap namesHsDeclTS ds) `mappend` ([],[(z,sl)]) where
+    Just z = maybeGetDeclName cd
+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 
+    _ -> []
+
+getHsNamesFromHsPat :: HsPat -> [HsName]
+getHsNamesFromHsPat (HsPVar hsName) = [hsName]
+getHsNamesFromHsPat (HsPLit _hsName) = []
+getHsNamesFromHsPat (HsPNeg hsPat) = getHsNamesFromHsPat hsPat
+-- _hsName can be ignored as it is a Constructor (e.g. in (x:xs) we only want to know what's in scope; that is x and xs)
+getHsNamesFromHsPat (HsPInfixApp hsPat1 _hsName hsPat2) = getHsNamesFromHsPat hsPat1 ++ getHsNamesFromHsPat hsPat2
+getHsNamesFromHsPat (HsPApp _hsName hsPats) = concat (map getHsNamesFromHsPat hsPats)
+getHsNamesFromHsPat (HsPTuple hsPats) = concat (map getHsNamesFromHsPat hsPats)
+getHsNamesFromHsPat (HsPList hsPats) = concat (map getHsNamesFromHsPat hsPats)
+getHsNamesFromHsPat (HsPParen hsPat) = getHsNamesFromHsPat hsPat
+getHsNamesFromHsPat (HsPRec _hsName hsPatFields) = concat $ map getHsNamesFromHsPatField hsPatFields -- hsName can be ignored as it is a Constructor
+getHsNamesFromHsPat (HsPAsPat hsName hsPat) = hsName:(getHsNamesFromHsPat hsPat)
+getHsNamesFromHsPat (HsPWildCard) = []
+getHsNamesFromHsPat (HsPIrrPat hsPat) = getHsNamesFromHsPat hsPat
+
+-- the hsName can be ignored as it is the field name and must already be in scope
+getHsNamesFromHsPatField :: HsPatField -> [HsName]
+{-
+getHsNamesFromHsPatField (HsPFieldPun _hsName)
+  = []
+  -}
+getHsNamesFromHsPatField (HsPFieldPat _hsName hsPat)
+  = getHsNamesFromHsPat hsPat
+
+getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)]
+getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp)
+  = zip (getHsNamesFromHsPat 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.
+
+getNewHsNamesFromHsQualType :: SubTable -> HsQualType -> [HsName]
+getNewHsNamesFromHsQualType subTable (HsQualType _hsContext hsType)
+  = getNewHsNamesFromHsType subTable hsType
+getNewHsNamesFromHsQualType subTable (HsUnQualType hsType)
+  = getNewHsNamesFromHsType subTable hsType
+
+getNewHsNamesFromHsType :: SubTable -> HsType -> [HsName]
+getNewHsNamesFromHsType subTable (HsTyFun hsType1 hsType2)
+  = (getNewHsNamesFromHsType subTable hsType1) ++ (getNewHsNamesFromHsType subTable hsType2)
+getNewHsNamesFromHsType subTable (HsTyTuple hsTypes)
+  = concat $ map (getNewHsNamesFromHsType subTable) hsTypes
+getNewHsNamesFromHsType subTable (HsTyApp hsType1 hsType2)
+  = (getNewHsNamesFromHsType subTable hsType1) ++ (getNewHsNamesFromHsType subTable hsType2)
+getNewHsNamesFromHsType subTable (HsTyVar hsName)
+  | lookupFM subTable hsName == Nothing = [hsName]
+  | otherwise                           = []
+getNewHsNamesFromHsType _subTable (HsTyCon _hsName)
+  = [] -- don't rename the Constructors
+
+getHsNamesFromHsQualType :: HsQualType -> [HsName]
+getHsNamesFromHsQualType (HsQualType _hsContext hsType)
+  = getHsNamesFromHsType hsType
+getHsNamesFromHsQualType (HsUnQualType hsType)
+  = getHsNamesFromHsType hsType
+
+getHsNamesFromHsType :: HsType -> [HsName]
+getHsNamesFromHsType (HsTyFun hsType1 hsType2)
+  = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)
+getHsNamesFromHsType (HsTyTuple hsTypes)
+  = concat $ map getHsNamesFromHsType hsTypes
+getHsNamesFromHsType (HsTyApp hsType1 hsType2)
+  = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)
+getHsNamesFromHsType (HsTyVar hsName)
+  = [hsName]
+getHsNamesFromHsType (HsTyCon _hsName)
+  = [] -- don't rename the Constructors
+
+
+-- gets the names of the functions declared in a class declaration
+
+getHsNamesFromClass :: HsDecl -> [HsName]
+getHsNamesFromClass (HsClassDecl _srcLoc _hsQualType hsDecls)
+  = getHsNamesFromTypeSigs hsDecls
+getHsNamesFromClass _otherDecl
+  = []
+
+-- gets the names of the functions whose types are declared in class decls
+
+getHsNamesFromTypeSigs :: [HsDecl] -> [HsName]
+getHsNamesFromTypeSigs ((HsTypeSig _srcLoc hsNames _hsQualType):hsDecls)
+  = hsNames ++ getHsNamesFromTypeSigs hsDecls
+getHsNamesFromTypeSigs (_otherDecl:hsDecls)
+  = getHsNamesFromTypeSigs hsDecls
+getHsNamesFromTypeSigs []
+  = []
+
+--------------------------------------------------------------------------------
+
+-- the Renameable class
+
+
+-- stores the instance Renameable for all of HsSyn
+
+class Renameable a where
+    replaceName :: (HsName -> HsName) -> a -> a
+
+instance Renameable SrcLoc where
+    replaceName f = id
+
+instance Renameable HsExportSpec where
+    replaceName f hsexportspec
+      = let a # b = a $ (replaceName f b)
+        in case hsexportspec of
+            HsEVar  name               ->
+                HsEVar  # name			
+            HsEAbs  name               ->
+                HsEAbs  # name			
+            HsEThingAll  name		 ->
+                HsEThingAll  # name		
+            HsEThingWith  name names	 ->
+                HsEThingWith  # name # names	
+            HsEModuleContents mod	 ->
+                HsEModuleContents mod	
+
+
+instance Renameable HsImportDecl where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+            a $$ b = a b
+            infixl 0 $$
+        in case object of
+            HsImportDecl  srcloc mod bool maybe1 maybe2 ->
+                HsImportDecl # srcloc $$ mod $$ bool $$ maybe1 $$ maybe2'
+                where maybe2' = fmap (\(b,importSpec) -> (b, replaceName f importSpec)) maybe2
+
+
+instance Renameable HsImportSpec where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsIVar  name			 ->
+                HsIVar  # name			
+            HsIAbs  name			 ->
+                HsIAbs  # name			
+            HsIThingAll  name		 ->
+                HsIThingAll  # name		
+            HsIThingWith  name names	 ->
+                HsIThingWith  # name # names	
+
+
+{-
+instance Renameable HsInfixDecl where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsInfixDecl  srcloc fixity names ->
+                HsInfixDecl  # srcloc # fixity # names
+-}
+
+
+{-
+instance Renameable HsFixity where
+    replaceName f = id
+-}
+
+instance Renameable HsAssoc where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsAssocNone  ->
+                HsAssocNone 
+            HsAssocLeft  ->
+                HsAssocLeft 
+            HsAssocRight  ->
+                HsAssocRight 
+
+
+instance Renameable (HsDecl) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsTypeDecl 	srcloc name names typ ->
+                HsTypeDecl 	srcloc # name # names # typ
+            HsDataDecl 	srcloc context name names condecls names' ->
+                HsDataDecl 	srcloc # context # name # names # condecls # names'
+            HsNewTypeDecl 	srcloc context name names condecl names' ->
+                HsNewTypeDecl 	srcloc # context # name # names # condecl # names'
+            HsClassDecl 	srcloc qualtyp objects ->
+                HsClassDecl 	srcloc # qualtyp # objects
+            HsInstDecl 	srcloc qualtyp objects ->
+                HsInstDecl 	srcloc # qualtyp # objects
+            HsDefaultDecl 	srcloc typ ->
+                HsDefaultDecl 	srcloc # typ
+            HsTypeSig 	srcloc names qualtyp ->
+                HsTypeSig 	srcloc # names # qualtyp
+            -- HsFunBind       srcloc matc ->
+            HsFunBind          matc ->
+                -- HsFunBind  # srcloc # matc
+                HsFunBind  # matc
+            HsPatBind 	srcloc pat r {-where-} objects ->
+                HsPatBind 	srcloc # pat # r # objects
+            od -> od
+
+
+instance Renameable (HsMatch) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsMatch  srcloc name pats r {-where-} objects ->
+                HsMatch  # srcloc # name # pats # r # objects
+
+
+instance Renameable HsConDecl where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsConDecl  srcloc name bangtyps ->
+                HsConDecl  # srcloc # name # bangtyps
+            HsRecDecl  srcloc name names_and_bangtyp ->
+                HsRecDecl  # srcloc # name # names_and_bangtyp
+
+
+
+
+instance Renameable HsBangType where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsBangedTy    typ ->
+                HsBangedTy  # typ
+            HsUnBangedTy  typ ->
+                HsUnBangedTy  # typ
+
+
+instance Renameable (HsRhs) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsUnGuardedRhs  exp ->
+                HsUnGuardedRhs  # exp
+            HsGuardedRhss   guardedrs ->
+                HsGuardedRhss  # guardedrs
+
+
+instance Renameable (HsGuardedRhs) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsGuardedRhs  srcloc exp exp' ->
+                HsGuardedRhs  # srcloc # exp # exp'
+
+
+instance Renameable HsQualType where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsQualType    context typ ->
+                HsQualType  # context # typ
+            HsUnQualType  typ ->
+                HsUnQualType  # typ
+
+
+instance Renameable HsType where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsTyFun    typ typ' ->
+                HsTyFun  # typ # typ'
+            HsTyTuple  typs ->
+                HsTyTuple  # typs
+            HsTyApp    typ typ' ->
+                HsTyApp  # typ # typ'
+            HsTyVar    name ->
+                HsTyVar  # name
+            HsTyCon    name ->
+                HsTyCon  # name
+
+instance Renameable HsLiteral where
+    replaceName f = id
+
+instance Renameable (HsExp) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            -- HsVar  name ann -> HsVar (replaceName f name) ann
+            HsVar  name -> HsVar (replaceName f name) 
+            HsCon  name ->
+                HsCon  # name 
+            HsLit  literal ->
+                HsLit  # literal
+            HsInfixApp  exp exp' exp'' ->
+                HsInfixApp  # exp # exp' # exp''
+            HsApp  exp exp' ->
+                HsApp  # exp # exp'
+            HsNegApp  exp ->
+                HsNegApp  # exp
+            HsLambda  srcloc pats exp ->
+                HsLambda  # srcloc # pats # exp
+            HsLet  objects exp ->
+                HsLet  # objects # exp
+            HsIf  exp exp' exp'' ->
+                HsIf  # exp # exp' # exp''
+            HsCase  exp alts ->
+                HsCase  # exp # alts
+            HsDo  stmts ->
+                HsDo  # stmts
+            HsTuple  exps ->
+                HsTuple  # exps
+            HsList  exps ->
+                HsList  # exps
+            HsParen  exp ->
+                HsParen  # exp
+            HsLeftSection  exp exp' ->
+                HsLeftSection  # exp # exp'
+            HsRightSection  exp exp' ->
+                HsRightSection  # exp # exp'
+            HsRecConstr  name fieldupdates ->
+                HsRecConstr  # name # fieldupdates
+            HsRecUpdate  exp fieldupdates ->
+                HsRecUpdate  # exp # fieldupdates
+            HsEnumFrom  exp ->
+                HsEnumFrom  # exp
+            HsEnumFromTo  exp exp' ->
+                HsEnumFromTo  # exp # exp'
+            HsEnumFromThen  exp exp' ->
+                HsEnumFromThen  # exp # exp'
+            HsEnumFromThenTo  exp exp' exp'' ->
+                HsEnumFromThenTo  # exp # exp' # exp''
+            HsListComp  exp stmts ->
+                HsListComp  # exp # stmts
+            HsExpTypeSig  srcloc exp qualtyp ->
+                HsExpTypeSig  # srcloc # exp # qualtyp
+            HsAsPat  name exp		 ->
+                HsAsPat  # name # exp		
+            HsWildCard sl 			 ->
+                HsWildCard sl			
+            HsIrrPat  exp		 ->
+                HsIrrPat  # exp		
+
+instance Renameable HsPat where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsPVar  name ->
+                HsPVar  # name
+            HsPLit  literal ->
+                HsPLit  # literal
+            HsPNeg  pat ->
+                HsPNeg  # pat
+            HsPInfixApp  pat name pat' ->
+                HsPInfixApp  # pat # name # pat'
+            HsPApp  name pats ->
+                HsPApp  # name # pats
+            HsPTuple  pats ->
+                HsPTuple  # pats
+            HsPList  pats ->
+                HsPList  # pats
+            HsPParen  pat ->
+                HsPParen  # pat
+            HsPRec  name patfields ->
+                HsPRec  # name # patfields
+            HsPAsPat  name pat ->
+                HsPAsPat  # name # pat
+            HsPWildCard  ->
+                HsPWildCard 
+            HsPIrrPat  pat ->
+                HsPIrrPat  # pat
+
+
+instance Renameable HsPatField where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+{-
+            HsPFieldPun  name ->
+                HsPFieldPun  # name
+-}
+            HsPFieldPat  name pat ->
+                HsPFieldPat  # name # pat
+
+
+instance Renameable (HsStmt) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsGenerator  srcloc pat exp ->
+                HsGenerator  # srcloc # pat # exp
+            HsQualifier  exp ->
+                HsQualifier  # exp
+            HsLetStmt  objects ->
+                HsLetStmt  # objects
+
+
+instance Renameable (HsFieldUpdate) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+{-
+            HsFieldBind  name ->
+                HsFieldBind  # name
+-}
+            HsFieldUpdate  name exp ->
+                HsFieldUpdate  # name # exp
+
+
+instance Renameable (HsAlt) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsAlt  srcloc pat guardedalts objects ->
+                HsAlt  # srcloc # pat # guardedalts # objects
+
+
+instance Renameable (HsGuardedAlts) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsUnGuardedAlt  exp ->
+                HsUnGuardedAlt  # exp
+            HsGuardedAlts   guardedalts ->
+                HsGuardedAlts  # guardedalts
+
+instance Renameable (HsGuardedAlt) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsGuardedAlt  srcloc exp exp' ->
+                HsGuardedAlt  # srcloc # exp # exp'
+
+instance Renameable HsName where 
+    replaceName f name = f name
+
+instance (Renameable a, Renameable b) => Renameable (a,b) where
+    replaceName f (x,y) = (replaceName f x, replaceName f y)
+instance Renameable a => Renameable [a] where
+    replaceName f xs = map (replaceName f) xs
+
+
+-- Ident table stuff
+type IdentTable = FiniteMap HsName (SrcLoc, Binding) 
+addToIdentTable _ _ = return ()
+
+{-
+printIdentTable :: IdentTable -> IO ()
+printIdentTable idt
+   = putStr $ unlines $ map showIdentTabEntry $ toListFM idt 
+   where
+   showIdentTabEntry :: (HsName, (SrcLoc, Binding)) -> String
+   showIdentTabEntry (name, (SrcLoc fn row col, bind)) 
+      = lJustify 40 (fromHsName name) ++ 
+        fn ++ ":" ++ showPos (row, col) ++ 
+        rJustify 10 (show bind)
+   showPos pos@(row, col)
+      | row < 0 || col < 0 = rJustify 10 "none" 
+      | otherwise          = rJustify 10 $ show pos 
+
+-- returns the binding type of a given identifier
+
+bindOfId :: IdentTable -> HsName -> Binding
+bindOfId idtab i
+   = case lookupFM idtab i of 
+        Nothing -> error $ "bindOfId: could not find binding for this identifier: " ++ show i
+        Just (_sloc, bind) -> bind
+addToIdentTable :: HsName -> (SrcLoc,Binding) -> ScopeSM ()
+addToIdentTable hsName srcLocAndBinding
+   = modify (\state -> state {identTable = addToFM (identTable state) hsName srcLocAndBinding })
+-}
addfile ./FrontEnd/Representation.hs
hunk ./FrontEnd/Representation.hs 1
+{-
+        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 Representation(
+    Type(..), 
+    Tyvar(..), 
+    tyvar,
+    Tycon(..),
+    fn,
+    Kind(..),
+    Kindvar(..),
+    unfoldKind,
+    Pred(..),
+    Qual(..),
+    Class,
+    Subst,
+    getTypeCons,
+    Scheme(..),
+    Assump(..),
+    tList
+    )where
+
+
+import HsSyn    
+import PPrint(Doc,pprint,PPrint,pptuple,nest)
+import Utils 
+import Data.FiniteMap
+import Data.Generics
+import Atom
+import VConsts
+import Utils
+import qualified FlagDump as FD
+import Options
+import Binary
+import Doc.DocLike
+import qualified Doc.DocLike as D
+
+
+--------------------------------------------------------------------------------
+
+-- Types
+
+
+data Type  = TVar {-# UNPACK #-} !Tyvar
+           | TCon !Tycon
+           | TAp  Type Type
+           | TGen {-# UNPACK #-} !Int {-# UNPACK #-} !Tyvar
+           | TArrow Type Type
+             deriving(Data,Typeable, Ord, Show)
+    {-! derive: GhcBinary !-}
+
+instance TypeNames Type where
+    tBool = TCon (Tycon (Qual (Module "Prelude") (HsIdent "Bool")) Star)
+    tString = TAp tList tChar
+    tChar      = TCon (Tycon (Qual (Module "Prelude") (HsIdent "Char")) Star)
+    tUnit = TCon (Tycon (Qual (Module "Prelude") (HsIdent "()")) Star)
+    
+tList = TCon (Tycon (Qual (Module "Prelude") (HsIdent "[]")) (Kfun Star Star))
+
+instance Eq Type where
+    (TVar a) == (TVar b) = a == b
+    (TCon a) == (TCon b) = a == b
+    (TAp a' a) == (TAp b' b) = a' == b' && b == a
+    (TGen a _) == (TGen b _) = a == b
+    (TArrow a' a) == (TArrow b' b) = a' == b' && b == a
+--    (TTuple a) == (TTuple b) = a == b
+    _ == _ = False
+
+
+-- Unquantified type variables
+
+data Tyvar = Tyvar {-# UNPACK #-} !Atom  !HsName Kind
+    deriving(Data,Typeable, Show)
+    {-! derive: GhcBinary !-}
+
+tyvar n k = Tyvar (fromString $ fromHsName n) n k
+
+instance Eq Tyvar where
+    Tyvar x _ _ == Tyvar y _ _ = x == y
+    Tyvar x _ _ /= Tyvar y _ _ = x /= y
+
+instance Ord Tyvar where
+    compare (Tyvar x _ _) (Tyvar y _ _) = compare x y
+    (Tyvar x _ _) <= (Tyvar y _ _) = x <= y
+    (Tyvar x _ _) >= (Tyvar y _ _) = x >= y
+    (Tyvar x _ _) < (Tyvar y _ _)  = x < y
+    (Tyvar x _ _) > (Tyvar y _ _)  = x > y
+
+
+
+-- Type constructors
+
+data Tycon = Tycon HsName Kind
+    deriving(Data,Typeable, Eq, Show,Ord)
+    {-! derive: GhcBinary !-}
+
+instance ToTuple Tycon where
+    toTuple n = Tycon (toTuple n) (foldr Kfun Star $ replicate n Star)
+instance ToTuple Type where
+    toTuple n = TCon $ toTuple n
+instance ToTuple Scheme where
+    toTuple n = Forall [] ([] :=> toTuple n)
+
+-- pretty printing for types etc:
+
+instance PPrint Doc Type where
+  pprint t = fst $ runVarName [] Utils.nameSupply $ prettyPrintTypeM t
+
+-- the trickery is to map TVars and TGens into nice 
+-- variable names: a, b, c, d, and so on when we print them
+
+prettyPrintTypeM :: Type -> VarName Doc
+prettyPrintTypeM t
+   = case t of
+           TVar (Tyvar _ tv _) -> do 
+                            findResult <- lookupInMap t 
+                            case findResult of
+                               Nothing -> do nm <- nextName
+                                             updateVMap (t, nm)
+                                             return (text nm)
+                               --Just v  -> return $ text v 
+                               Just v  -> return $ text v <> tyvar (text (show tv))
+           TCon tycon -> return $ pprint tycon
+           -- check for the Prelude.[] special case
+           TAp t1 t2  -> do case tList == t1 of
+                               True  -> do doc  <- prettyPrintTypeM t2
+                                           return $ brackets doc
+                               False -> do doc1 <- prettyPrintTypeM t1
+                                           doc2 <- maybeParensAp t2 
+                                           return $ doc1 <+> doc2
+           TGen _ (Tyvar _ tv _)   -> do 
+                            findResult <- lookupInMap t 
+                            case findResult of
+                                Nothing -> do 
+                                    nm <- nextName
+                                    updateVMap (t, nm)
+                                    --return (text nm)
+                                    return (text nm <> parens (text (show tv)))
+                                Just v  -> return $ text v <> tyvar (text (show tv))
+           TArrow t1 t2 -> do doc1 <- maybeParensArrow t1
+                              doc2 <- prettyPrintTypeM t2
+                              return $ doc1 <> text " -> " <> doc2
+--           TTuple ts    -> do tsDocs <- mapM prettyPrintTypeM ts
+--                              return $ parens $ hcat $ punctuate comma tsDocs
+    where
+    -- puts parentheses around the doc for a type if needed
+    maybeParensAp :: Type -> VarName Doc
+    maybeParensAp t
+       = do case t of
+               TAp t1 _   -> do case tList == t1 of
+                                   True  -> prettyPrintTypeM t
+                                   False -> do doc <- prettyPrintTypeM t
+                                               return $ parens doc
+               _anything  -> maybeParensArrow t
+    maybeParensArrow :: Type -> VarName Doc
+    maybeParensArrow t
+       = do case t of
+               TArrow {} -> do doc <- prettyPrintTypeM t
+                               return $ parens doc
+               _  -> prettyPrintTypeM t
+    tyvar d = if dump FD.Tyvar then parens d else empty
+
+
+instance PPrint Doc Tycon where
+   pprint (Tycon i _) = pprint i 
+
+infixr      4 `fn`
+fn         :: Type -> Type -> Type
+a `fn` b    = TArrow a b
+
+--------------------------------------------------------------------------------
+
+-- Kinds
+
+data Kind  = Star
+           | Kfun Kind Kind
+           | KVar Kindvar               -- variables aren't really allowed in haskell in kinds
+             deriving(Data,Typeable, Eq, Ord, Show)   -- but we need them for kind inference
+    {-! derive: GhcBinary !-}
+
+newtype Kindvar = Kindvar Int deriving(Data, Binary,Typeable, Ord, Eq, Show)
+
+instance DocLike d => PPrint d Kind where
+   pprint Star = text "*"
+   pprint (Kfun Star Star) = text "* -> *"
+   pprint (Kfun k1   Star) = text "(" <> pprint k1 <> text ")" <> text " -> *"
+   --pprint (Kfun Star k2)   = text "*->" <> text "(" <> pprint k2 <> text ")"
+   pprint (Kfun Star k2)   = text "* -> " <> pprint k2 
+   pprint (Kfun k1   k2)   = text "(" <> pprint k1 <> text ") -> (" <> pprint k2 <> text ")"
+   pprint (KVar kindVar)   = pprint kindVar
+
+instance DocLike d =>  PPrint d Kindvar where
+   pprint (Kindvar s) = text $ 'k':show s 
+
+--  * -> * == [*,*]
+--  (*->*->*) -> * -> * == [(*->*->*), *, *]
+unfoldKind :: Kind -> [Kind]
+unfoldKind Star = [Star]
+unfoldKind (KVar v) = [KVar v]
+unfoldKind (Kfun k1 k2) = k1 : unfoldKind k2
+
+--------------------------------------------------------------------------------
+
+-- Predicates
+data Pred   = IsIn Class Type
+              deriving(Data,Typeable, Show, Eq,Ord)
+    {-! derive: GhcBinary !-}
+
+instance PPrint Doc Pred where
+  -- pprint (IsIn c t) = pprint c <+> pprint t 
+  pprint pred 
+     = fst $ runVarName [] Utils.nameSupply $ prettyPrintPredM pred
+
+prettyPrintPredM :: Pred -> VarName Doc
+prettyPrintPredM (IsIn c t)
+   = do typeDoc <- prettyPrintTypeM t
+        return $ pprint c <+> typeDoc
+
+-- Qualified entities  
+data Qual t =  [Pred] :=> t
+              deriving(Data,Typeable, Show, Eq,Ord)
+    {-! derive: GhcBinary !-}
+
+prettyPrintQualPredM :: Qual Pred -> VarName Doc
+prettyPrintQualPredM (preds :=> pred)
+   = do case preds of
+           []            -> prettyPrintPredM pred 
+           [p]           -> do leftPredDoc  <- prettyPrintPredM p
+                               rightPredDoc <- prettyPrintPredM pred 
+                               return $ hsep [leftPredDoc, text "=>", rightPredDoc]
+           preds@(_:_:_) -> do docs <- mapM prettyPrintPredM preds 
+                               let predsDoc = parens (hcat (punctuate comma docs)) 
+                               rightPredDoc <- prettyPrintPredM pred
+                               return $ hsep [predsDoc, text "=>", rightPredDoc] 
+
+
+
+-- special case for qualified types
+prettyPrintQualTypeM :: Qual Type -> VarName Doc
+prettyPrintQualTypeM (preds :=> t)
+   = do case preds of
+           []            -> prettyPrintTypeM t
+           [p]           -> do predDoc <- prettyPrintPredM p 
+                               typeDoc <- prettyPrintTypeM t
+                               return $ hsep [predDoc, text "=>", typeDoc]
+           preds@(_:_:_) -> do docs <- mapM prettyPrintPredM preds 
+                               let predsDoc = parens (hcat (punctuate comma docs))
+                               typeDoc <- prettyPrintTypeM t
+                               return $ hsep [predsDoc, text "=>", typeDoc]
+ 
+-- Class
+type Class = HsName
+
+--instance PPrint Doc t => PPrint Doc (Qual t) where
+--  pprint (ps :=> t) = pptuple ps <+> text "=>" <+> pprint t
+
+instance PPrint Doc (Qual Pred) where 
+    pprint inst = fst $ runVarName [] Utils.nameSupply $ prettyPrintQualPredM inst
+
+instance PPrint Doc (Qual Type) where 
+    pprint inst = fst $ runVarName [] Utils.nameSupply $ prettyPrintQualTypeM inst
+
+--prettyPrintInst :: Inst -> Doc
+--prettyPrintInst inst 
+--   = fst $ runVarName [] Utils.nameSupply $ prettyPrintQualPredM inst
+
+--------------------------------------------------------------------------------
+
+-- substitutions
+
+type Subst  = FiniteMap Atom Type
+
+--------------------------------------------------------------------------------
+
+getTypeCons (TCon (Tycon n _)) = n
+getTypeCons (TAp a _) = getTypeCons a
+getTypeCons (TArrow {}) = Qual (Module "Prelude") $ HsIdent "->"
+--getTypeCons (TTuple xs) = Qual (Module "Prelude") $ HsIdent ("(" ++ (replicate (length xs - 1) ',') ++ ")")
+--getTypeCons (TTuple xs) | n <- length xs, n > 1  = toTuple n
+getTypeCons x = error $ "getTypeCons: " ++ show x
+
+-- schemes
+
+
+data Scheme = Forall [Kind] (Qual Type)
+              deriving(Data,Typeable, Eq, Show, Ord)
+    {-! derive: GhcBinary !-}
+
+instance PPrint Doc Scheme where
+  pprint scheme 
+    = fst $ runVarName [] Utils.nameSupply $ prettyPrintSchemeM scheme
+
+prettyPrintSchemeM :: Scheme -> VarName Doc
+prettyPrintSchemeM (Forall _kinds qType)
+   = prettyPrintQualTypeM qType
+
+--------------------------------------------------------------------------------
+
+-- assumptions
+
+data Assump =  (:>:) HsName Scheme
+    deriving(Ord,Eq,Data,Typeable, Show)
+    {-! derive: GhcBinary !-}
+
+instance  PPrint Doc Assump where
+  pprint (i :>: s) = (text (show i) <+> text ":>:") <$> nest 2 (pprint s)
+
+
+--------------------------------------------------------------------------------
+
+-- a monad for matching type variables with nice names for pretty printing
+
+newtype VarName a = VarName (State -> (a, State))  deriving(Typeable)
+
+type VMap = [(Type, String)]  -- maps type (vars) to strings
+type NameSupply = [String]    -- a fresh name supply 
+
+data State = State {
+      vmap  :: VMap,       -- the map of variables to names 
+      names :: NameSupply  -- a fresh name Supply 
+   } deriving(Typeable)
+
+instance Monad VarName where
+    return a 
+        = VarName (\state -> (a, state))
+    VarName comp >>= fun   
+        = VarName (\state -> let (result, newState) = comp state
+                                 VarName comp' = fun result
+                             in comp' newState)
+
+runVarName :: VMap -> NameSupply -> VarName a -> (a, State)
+runVarName varMap nameSupp (VarName comp)
+   = (result, newState)
+   where
+   (result,newState)
+      = comp (State {vmap  = varMap,
+                     names = nameSupp})
+
+select :: (State -> a) -> VarName a
+select selector = VarName (\state -> (selector state, state))
+
+getVMap :: VarName VMap
+getVMap = select vmap 
+
+updateVMap :: (Type, String) -> VarName ()
+updateVMap newEntry
+   = VarName (\state -> let oldmap = vmap state
+                        in ((), state {vmap = newEntry : oldmap}))  
+
+nextName :: VarName String
+nextName 
+   = VarName (\state -> let oldNames = names state
+                        in (head oldNames, state {names = tail oldNames}))
+
+lookupInMap :: Type -> VarName (Maybe String)
+lookupInMap t 
+   = do m <- getVMap
+        return $ lookup t m 
addfile ./FrontEnd/TIMain.hs
hunk ./FrontEnd/TIMain.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              Mark Jones and The Hatchet Team 
+                                (see file Contributors)
+
+        Module:                 TIMain
+
+        Description:            The main components of the type inference 
+                                algorithm.
+
+        Primary Authors:        Mark Jones, Bernie Pope and Bryn Humberstone
+
+        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 TIMain (tiProgram, makeProgram, getFunDeclsBg) where
+
+import List                     ((\\), intersect, union)
+import FrontEnd.Desugar         (doToExp)
+import HsPretty 
+import qualified PPrint
+import HsSyn
+import Representation     
+import Type      
+import Monad                    (zipWithM)
+import Diagnostic 
+import Class                    (ClassHierarchy,
+                                 entails,
+                                 split,
+                                 topDefaults,
+                                 splitReduce,
+                                 reduce)
+
+import TIMonad
+
+
+import Utils                    (isSigDecl,
+                                 isBindDecl,
+                                 fromHsName,
+                                 getDeclName,
+                                 groupEquations,
+                                 Binding (..),
+                                 fst3,
+                                 snd3,
+                                 trd3)
+
+
+import DependAnalysis           (getBindGroups)
+import Maybe                    (fromMaybe)
+import TypeUtils                (aHsTypeSigToAssumps)
+import TypeSigs                 (SigEnv)
+import FrontEnd.Env                     
+import Data.FiniteMap
+import VConsts
+                                   
+import DeclsDepends             (getDeclDeps)                                
+import Control.Monad.Error
+import KindInfer(KindEnv)
+import qualified Data.Map as Map
+import Doc.PPrint
+
+
+
+strace _ s = s
+
+-- a TypeEnv maps identifier names to type schemes
+type TypeEnv = Env Scheme
+
+instance Types a => Types (HsName, a) where
+   apply s (x, y) = (x, apply s y)
+   tv (_, y) = tv y 
+
+instance Types TypeEnv where
+   apply s = mapFM (\k e -> apply s e)
+   tv env = tv $ map snd $ toListFM env
+
+
+tiExpr ::  TypeEnv -> (HsExp) -> TI ([Pred], TypeEnv, Type)
+
+tiExpr env (HsVar v) | Just sc <- lookupEnv v env = do
+          (ty@(ps :=> t)) <- freshInst sc
+          --addInstance ((v,n),ty)
+          return (ps, emptyEnv, t)
+tiExpr env (HsVar v) = error $ "tiExpr: could not find type scheme for: " ++ show v ++ " " ++ showEnv env        
+    
+{-
+                  
+ = do let sc = case lookupEnv v env of
+                  Nothing -> error $ "tiExpr: could not find type scheme for: " ++ 
+		                     show v ++ " " ++ showEnv env 
+                  Just scheme -> scheme
+      (ty@(ps :=> t)) <- freshInst sc
+      --addInstance ((v,n),ty)
+      return (ps, emptyEnv, t)
+-}
+
+tiExpr env (HsCon conName)
+ = do 
+      sc <- dConScheme conName
+      (ty@(ps :=> t)) <- freshInst sc
+      --addInstance ((conName,n),ty)
+      return (ps, emptyEnv, t)
+
+tiExpr _env (HsLit l)
+ = do (ps,t) <- tiLit l
+      return (ps, emptyEnv, t)
+
+tiExpr env (HsAsPat n e) = do
+    (ps,nenv, t) <- tiExpr env e 
+    --let newAssump = makeAssump n $ toScheme t
+    --let newEnv = addToEnv (assumpToPair newAssump) nenv
+    let newEnv = addToEnv (n,toScheme t) nenv
+    return (ps, newEnv, t)
+
+
+tiExpr env expr@(HsInfixApp e1 e2 e3)
+ = withContext 
+       (makeMsg "in the infix application" $ render $ ppHsExp expr) $
+       do
+       (ps, env1, te1) <- tiExpr env e1 
+       (qs, env2, te2) <- tiExpr env e2 
+       (rs, env3, te3) <- tiExpr env e3 
+       tout      <- newTVar Star
+       unify (te1 `fn` (te3 `fn` tout)) te2
+       return (ps ++ qs ++ rs, env1 `joinEnv` env2 `joinEnv` env3, tout)
+
+tiExpr env expr@(HsApp e1 e2)
+ = withContext
+      (makeMsg "in the application" $ render $ ppHsExp expr) $
+      do
+      (ps, env1, te1) <- tiExpr env e1
+      (qs, env2, te2) <- tiExpr env e2 
+      t           <- newTVar Star
+      unify (te2 `fn` t) te1
+      return (ps++qs, env1 `joinEnv` env2, t)
+
+-- we need to fix the type to to be in the class
+-- cNum, just for cases such as:
+-- foo = \x -> -x
+
+tiExpr env expr@(HsNegApp e)
+ = withContext
+      (makeMsg "in the negative expression" $ render $ ppHsExp expr) $
+      do
+        (ps, env1, te) <- tiExpr env e
+        return (IsIn classNum te : ps, env1, te) 
+
+tiExpr env expr@(HsLambda sloc pats e)
+ = withContext
+      (locSimple sloc $ "in the lambda expression\n   \\" ++ show pats ++ " -> ...") $
+      do
+        (ps, envP, ts) <- tiPats pats
+        (qs, envE, t)  <- tiExpr (envP `joinEnv` env) e
+        return (ps++qs, envP `joinEnv` envE, foldr fn t ts)  -- Boba
+
+tiExpr env expr@(HsLet decls e)
+ = withContext 
+       (makeMsg "in the let binding" $ render $ ppHsExp expr) $
+         do
+         sigEnv <- getSigEnv
+         let bgs = getFunDeclsBg sigEnv decls
+         (ps, env1) <- tiSeq tiBindGroup env bgs
+         (qs, env2, t) <- tiExpr (env1 `joinEnv` env) e
+         -- keep the let bound type assumptions in the environment
+         return (ps ++ qs, env1 `joinEnv` env2, t) 
+
+tiExpr env (HsIf e e1 e2)
+ = withContext
+      (simpleMsg $ 
+      "in the conditional expression\n   if " ++ show e ++ "...") $
+      do (ps, env1, t)   <- tiExpr env e
+         unify t tBool
+         (ps1, env2, t1) <- tiExpr env e1
+         (ps2, env3, t2) <- tiExpr env e2
+         unify t1 t2
+         return (ps++ps1++ps2, env1 `joinEnv` env2 `joinEnv` env3, t1)
+
+
+tiExpr env (HsCase e alts)
+ = withContext
+        (simpleMsg $
+            "in the case expression\n   case " ++ show e ++ " of ...") $
+        do
+        (pse, env1, te)    <- tiExpr env e
+        psastsAlts     <- mapM (tiAlt env) alts
+        let pstsPats = map fst3 psastsAlts
+        let psPats   = concatMap fst pstsPats
+        let tsPats   = map snd pstsPats
+        let pstsEs   = map trd3 psastsAlts
+        let psEs     = concatMap fst pstsEs
+        let tsEs     = map snd pstsEs
+        let envAlts  = joinListEnvs $ map snd3 psastsAlts
+        unifyList (te:tsPats)
+        unifyList tsEs
+        -- the list of rhs alternatives must be non-empty
+        -- so it is safe to call head here
+        return (pse ++ psPats ++ psEs, env1 `joinEnv` envAlts, head tsEs)
+
+
+tiExpr env (HsDo stmts)
+   = do
+        let newExp = doToExp stmts
+        withContext (simpleMsg "in a do expression") 
+                    (tiExpr env newExp)
+
+-- tuples can't be empty, () is not a tuple
+tiExpr env tuple@(HsTuple exps@(_:_))
+   = withContext                
+        (makeMsg "in the tuple" $ render $ ppHsExp tuple) $
+        do
+           psasts <- mapM (tiExpr env) exps
+           let typeList = map trd3 psasts
+           let preds = concatMap fst3 psasts
+           let env1 = joinListEnvs $ map snd3 psasts
+           return (preds, env1, tTTuple typeList)
+
+-- special case for the empty list
+tiExpr _env (HsList [])
+   = do
+        v <- newTVar Star
+        return ([], emptyEnv, TAp tList v)
+
+-- non empty list
+tiExpr env expr@(HsList exps@(_:_))
+   = withContext (makeMsg "in the list " $ render $ ppHsExp expr) $
+        do
+        psasts <- mapM (tiExpr env) exps
+        let typeList = map trd3 psasts
+        unifyList typeList 
+        let preds = concatMap fst3 psasts
+        let env1 = joinListEnvs $ map snd3 psasts
+        return (preds, env1, TAp tList (head typeList)) 
+
+
+        
+tiExpr env (HsParen e) = tiExpr env e 
+
+-- e1 :: a -> b
+-- e2 :: a
+-- e1 e2 :: b
+
+{- XXX: we don't push error contexts for some cases, e.g.
+   HsLeftSection -}
+tiExpr env (HsLeftSection e1 e2)
+   = do
+        (e1Ps, envE1, e1T) <- tiExpr env e1
+        (e2Ps, envE2, e2T) <- tiExpr env e2
+        tv          <- newTVar Star
+        unify e1T (e2T `fn` tv)
+        return (e1Ps ++ e2Ps, envE1 `joinEnv` envE2, tv) 
+
+
+-- I know this looks weird but it appears to be correct 
+-- e1 :: b
+-- e2 :: a -> b -> c 
+-- e1 e2 :: a -> c
+
+tiExpr env (HsRightSection e1 e2)
+   = do
+        (e1Ps, envE1, e1T) <- tiExpr env e1
+        (e2Ps, envE2, e2T) <- tiExpr env e2
+        tv1         <- newTVar Star
+        tv2         <- newTVar Star
+        unify e2T (tv1 `fn` (e1T `fn` tv2))
+        return (e1Ps ++ e2Ps, envE1 `joinEnv` envE2, tv1 `fn` tv2) 
+
+tiExpr env (HsRecConstr _ _)
+   = error $ "tiExpr env (HsRecConstr _ _): not implemented"
+
+tiExpr env (HsRecUpdate _ _)
+   = error $ "tiExpr env (HsRecUpdate _ _): not implemented"
+
+tiExpr env (HsEnumFrom e)
+   = do
+        (ePs, envE, eT) <- tiExpr env e
+        return (IsIn classEnum eT : ePs, envE, TAp tList eT)
+
+tiExpr env (HsEnumFromTo e1 e2)
+   = do
+        (e1Ps, e1Env, e1T) <- tiExpr env e1
+        (e2Ps, e2Env, e2T) <- tiExpr env e2
+        unify e1T e2T
+        return (IsIn classEnum e1T : IsIn classEnum e2T : (e1Ps ++ e2Ps), 
+                e1Env `joinEnv` e2Env, 
+                TAp tList e1T)
+
+tiExpr env (HsEnumFromThen e1 e2)
+   = do
+        (e1Ps, e1Env, e1T) <- tiExpr env e1
+        (e2Ps, e2Env, e2T) <- tiExpr env e2
+        unify e1T e2T
+        return (IsIn classEnum e1T : IsIn classEnum e2T : (e1Ps ++ e2Ps), 
+                e1Env `joinEnv` e2Env, 
+                TAp tList e1T)
+
+tiExpr env (HsEnumFromThenTo e1 e2 e3)
+   = do
+        (e1Ps, e1Env, e1T) <- tiExpr env e1
+        (e2Ps, e2Env, e2T) <- tiExpr env e2
+        (e3Ps, e3Env, e3T) <- tiExpr env e3
+        unifyList [e1T,e2T,e3T]
+        return (IsIn classEnum e1T : IsIn classEnum e2T : IsIn classEnum e3T : (e1Ps ++ e2Ps ++ e3Ps), 
+                e1Env `joinEnv` e2Env `joinEnv` e3Env, 
+                TAp tList e1T)
+
+tiExpr env (HsListComp e stmts)
+   = do
+        psEnv <- tiStmts env stmts
+        let stmtsPs = fst psEnv
+        let stmtsEnv = snd psEnv 
+        (ePs, eEnv, eT) <- tiExpr (stmtsEnv `joinEnv` env) e
+        return (stmtsPs ++ ePs, eEnv `joinEnv` stmtsEnv, TAp tList eT)
+
+-- This should be desugared already
+-- e :: t   ----> let {v::t; v=e} in v
+tiExpr env (HsExpTypeSig _sloc e qt)
+   = error $ "tiExpr: unexpected sugared explicitly typed expression " ++ show e
+
+tiExpr _env e
+   = error $ "tiExpr: not implemented for: " ++ show e
+
+--------------------------------------------------------------------------------
+
+tiStmts ::  TypeEnv -> [(HsStmt)] -> TI ([Pred], TypeEnv)
+
+tiStmts = tiStmtsAcc [] emptyEnv 
+
+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 `joinEnv` env) s
+        tiStmtsAcc (newPs ++ predAcc) (newEnv `joinEnv` 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 `joinEnv` 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
+
+--------------------------------------------------------------------------------
+
+tiAlt ::  TypeEnv -> (HsAlt) -> TI (([Pred], Type), TypeEnv, ([Pred], Type))
+
+tiAlt env alt@(HsAlt sloc pat gAlts wheres)
+   = withContext (locMsg sloc "in the alternative" $ render $ ppHsAlt alt) $
+        do
+        sigEnv <- getSigEnv
+        let wheresBgs = getFunDeclsBg sigEnv wheres
+        (psPat, envPat, patT) <- tiPat pat
+        (wheresPs, wheresEnv) <- tiSeq tiBindGroup (envPat `joinEnv` env) wheresBgs
+        (psAlt, envAlt, tAlt) <- tiGuardedAlts (wheresEnv `joinEnv` envPat  `joinEnv` env) gAlts
+        -- not sure about the use of wheresPs below
+        return ((psPat, patT), envPat `joinEnv` envAlt `joinEnv` wheresEnv, (wheresPs ++ psAlt, tAlt)) --Boba
+                       
+
+tiGuardedAlts env (HsUnGuardedAlt e)
+   = tiExpr env e
+
+-- basically the same as HsGuardedRhss
+tiGuardedAlts env (HsGuardedAlts gAlts)
+   = withContext (simpleMsg "in guarded alternatives") $
+     do 
+        psEnvTs <- mapM (tiGuardedAlt env) gAlts 
+        let guardsPsEnvTs = map fst psEnvTs
+        let rhsPsEnvTs    = map snd psEnvTs
+        let guardPs    = concatMap fst3 guardsPsEnvTs
+        let rhsPs      = concatMap fst3 rhsPsEnvTs
+        let guardTs    = map trd3 guardsPsEnvTs
+        let rhsTs      = map trd3 rhsPsEnvTs
+        let guardEnv   = joinListEnvs $ map snd3 guardsPsEnvTs
+        let rhsEnv      = joinListEnvs $ map snd3 rhsPsEnvTs 
+        unifyList (tBool:guardTs)                -- make sure these are all booleans
+        unifyList rhsTs
+        return (guardPs ++ rhsPs, guardEnv `joinEnv` rhsEnv, head rhsTs)
+
+
+-- basically the same as tiGuardedRhs
+tiGuardedAlt ::  TypeEnv  -> (HsGuardedAlt) -> TI (([Pred], TypeEnv, Type), ([Pred], TypeEnv, Type))
+tiGuardedAlt env gAlt@(HsGuardedAlt sloc eGuard eRhs)
+   = withContext (locMsg sloc "in the guarded alternative" $ render $ ppGAlt gAlt) $
+     do
+        (guardPs, guardEnv, guardT) <- tiExpr env eGuard
+        (rhsPs, rhsEnv, rhsT)     <- tiExpr env eRhs 
+        return ((guardPs, guardEnv, guardT), (rhsPs, rhsEnv, rhsT))
+
+
+-----------------------------------------------------------------------------
+
+-- NOTE: there's no need to do tiDecl with error contexts as the unification
+--       doesn't happen until after this function is finished with
+tiDecl ::  TypeEnv -> HsDecl -> TI ([Pred], TypeEnv, Type)
+
+tiDecl env (HsForeignDecl _ _ _ n _) = do
+    sigEnv <- getSigEnv
+    let Just qt =  Map.lookup n sigEnv
+    ((ps :=> t)) <- freshInst qt
+    return (ps, env, t)
+    
+tiDecl env decl@(HsPatBind sloc pat rhs wheres) = withContext (declDiagnostic decl) $ do
+        sigEnv <- getSigEnv
+        let wheresBgs = getFunDeclsBg sigEnv wheres
+        (ps, env1)     <- tiSeq tiBindGroup env wheresBgs 
+        (qs, env2, t)  <- tiRhs (env1 `joinEnv` env) rhs
+        return (ps ++ qs, env1 `joinEnv` env2, t)
+
+
+tiDecl env decl@(HsFunBind matches)  = withContext (declDiagnostic decl) $ do
+        psEnvts <- mapM (tiMatch env) matches
+        let ps' = concatMap fst3 psEnvts
+        let ts' = map trd3 psEnvts
+        let matchesEnv = joinListEnvs $ map snd3 psEnvts
+        unifyList ts'  -- all matches must have the same type
+        return (ps', matchesEnv, head ts') 
+
+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 
+--    where
+--    matchLoc
+--       = case matches of 
+--            [] -> bogusASrcLoc  -- this should never happen, there should be no empty match list
+--            (m:_) -> case m of
+--                        HsMatch sloc _name _pats _rhs _decls -> sloc
+
+
+tiDeclTop ::  TypeEnv -> HsDecl -> Type -> TI ([Pred], TypeEnv)
+tiDeclTop env decl t
+   = do psEnvT <- tiDecl env decl 
+        unify t (trd3 psEnvT)
+        return (fst3 psEnvT, snd3 psEnvT)
+ 
+--------------------------------------------------------------------------------
+
+tiMatch ::  TypeEnv -> (HsMatch) -> TI ([Pred], TypeEnv, Type)
+tiMatch env (HsMatch sloc funName pats rhs wheres)
+   = withContext (locMsg sloc "in" $ render $ ppHsName funName) $
+     do
+        -- pats must be done before wheres b/c variables bound in patterns
+        -- may be referenced in the where clause
+        (patsPs, patsEnv, patsTs) <- tiPats pats
+        sigEnv <- getSigEnv
+        let wheresBgs = getFunDeclsBg sigEnv wheres 
+        (wheresPs, wheresEnv) <- tiSeq tiBindGroup (patsEnv `joinEnv` env) wheresBgs  
+        (rhsPs, rhsEnv, rhsT)   <- tiRhs (wheresEnv `joinEnv` patsEnv `joinEnv` env) rhs
+        return (wheresPs++patsPs++rhsPs, patsEnv `joinEnv` rhsEnv `joinEnv` wheresEnv, foldr fn rhsT patsTs)  --Boba
+
+-----------------------------------------------------------------------------
+
+
+tiRhs env (HsUnGuardedRhs e)
+   = tiExpr env e
+
+
+tiRhs env (HsGuardedRhss rhss)
+   = do
+        psEnvTs <- mapM (tiGuardedRhs env) rhss
+        let guardsPsEnvTs = map fst psEnvTs
+        let rhsPsEnvTs    = map snd psEnvTs
+        let guardPs    = concatMap fst3 guardsPsEnvTs
+        let rhsPs      = concatMap fst3 rhsPsEnvTs 
+        let guardTs    = map trd3 guardsPsEnvTs
+        let rhsTs      = map trd3 rhsPsEnvTs
+        let guardEnv    = joinListEnvs $ map snd3 guardsPsEnvTs
+        let rhsEnv      = joinListEnvs $ map snd3 rhsPsEnvTs 
+        unifyList (tBool:guardTs)                -- make sure these are all booleans
+        unifyList rhsTs
+        return (guardPs ++ rhsPs, guardEnv `joinEnv` rhsEnv, head rhsTs)
+        
+
+tiGuardedRhs ::  TypeEnv -> (HsGuardedRhs) -> TI (([Pred], TypeEnv, Type), ([Pred], TypeEnv, Type))
+tiGuardedRhs env gRhs@(HsGuardedRhs sloc eGuard eRhs)
+   = withContext (locMsg sloc "in the guarded right hand side" $ render $ ppHsGuardedRhs gRhs) $
+     do
+        (guardPs, guardEnv, guardT) <- tiExpr env eGuard
+        unify tBool guardT
+        (rhsPs, rhsEnv, rhsT)       <- tiExpr env eRhs
+        return ((guardPs, guardEnv, guardT), (rhsPs, rhsEnv, rhsT)) 
+
+        
+
+-----------------------------------------------------------------------------
+
+-- type check explicitly typed bindings
+
+type Expl = (Scheme, HsDecl)
+
+
+--tiExpl ::  TypeEnv -> Expl -> TI ([Pred], TypeEnv)
+tiExpl env (sc, decl)
+ = withContext 
+       (locSimple (srcLoc decl) ("in the explicitly typed " ++  (render $ ppHsDecl decl))) $
+    do 
+       cHierarchy <- getClassHierarchy
+       --(qs :=> t) <- fmap snd $ freshInst sc
+       let (qs :=> t) = unQuantify sc
+       (ps, env') <- tiDeclTop env decl t
+       s          <- getSubst
+       let qs'     = apply s qs
+           t'      = apply s t
+           ps'     = [ p | p <- apply s ps, not (entails cHierarchy qs' p) ]
+           fs      = tv (apply s env) 
+           gs      = tv t' {- \\ fs  -} -- TODO fix this!
+           sc'     = quantify gs (qs':=>t')
+       -- (ds,rs) <- reduce cHierarchy fs gs ps'
+       (ds,rs,nsub) <- splitReduce cHierarchy fs gs ps'
+       sequence_ [ unify  (TVar tv) t | (tv,t) <- nsub ]
+       --extSubst nsub
+       --unify t' t
+       --unify t t'
+       if sc /= sc' then
+           fail $ "signature too general for " ++ fromHsName (getDeclName decl) ++ "\n Given: " ++ show sc ++ "\n Infered: " ++ show sc'
+        else if not (null rs) then
+           fail $ "context too weak for "  ++ fromHsName (getDeclName decl) ++ "\nGiven: " ++ PPrint.render (pprint  sc) ++ "\nInfered: " ++ PPrint.render (pprint sc') ++"\nContext: " ++ PPrint.render (pprint  rs)
+        else
+           return (sc', ds,  env')
+           --return (sc', ds, env')
+
+-----------------------------------------------------------------------------
+
+-- type check implicitly typed bindings
+
+type Impl = HsDecl
+
+restricted   :: [Impl] -> Bool
+restricted bs 
+   = any isSimpleDecl bs
+   where 
+   isSimpleDecl :: (HsDecl) -> Bool
+   isSimpleDecl (HsPatBind _sloc _pat _rhs _wheres) = True
+   isSimpleDecl _ = False
+
+tiImpls env [] = return ([],env)
+tiImpls env bs = withContext (locSimple (srcLoc bs) ("in the implicitly typed: " ++ (show (map getDeclName bs)))) $ do
+      cHierarchy <- getClassHierarchy
+      ts <- mapM (\_ -> newTVar Star) bs
+      let 
+          is      = getImplsNames bs
+          scs     = map toScheme ts
+          newEnv1 = listToEnv $ zip is scs -- map assumpToPair $ zipWith makeAssump is scs 
+          env'    = newEnv1 `joinEnv` env 
+      pssEnvs <- sequence (zipWith (tiDeclTop env') bs ts)
+      let pss  = map fst pssEnvs
+      let envs = map snd pssEnvs
+      s   <- getSubst
+      let ps'     = apply s (concat pss)
+          ts'     = apply s ts
+          fs      = tv (apply s env)  
+          vss@(_:_)  = map tv ts'
+          gs      = foldr1 union vss \\ fs
+      -- (ds,rs) <- reduce cHierarchy fs (foldr1 intersect vss) ps'
+      (ds,rs,nsub) <- splitReduce cHierarchy fs (foldr1 intersect vss) ps'
+      sequence_ [ unify  (TVar tv) t | (tv,t) <- nsub ]
+      -- extSubst nsub
+      if restricted bs then
+          let gs'  = gs \\ tv rs
+              scs' = map (quantify gs' . ([]:=>)) ts'
+              newEnv2 = listToEnv $ zip is scs' -- map assumpToPair $ zipWith makeAssump is scs'
+          in return (ds++rs,  (joinListEnvs envs) `joinEnv` newEnv2)
+        else
+          let scs' = map (quantify gs . (rs:=>)) ts'
+              newEnv3 = listToEnv $ zip is scs' -- map assumpToPair $ zipWith makeAssump is scs'
+          in return (ds,  (joinListEnvs envs) `joinEnv` newEnv3)  
+
+getImplsNames :: [Impl] -> [HsName]
+getImplsNames impls
+   = map getDeclName impls
+
+
+-----------------------------------------------------------------------------
+
+
+-- 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], [Impl])
+
+tiBindGroup env (es, is)
+   = do 
+     modName <- getModName
+     --let env1 = listToEnv [assumpToPair $ getDeclName decl :>: sc | (sc,decl) <- es ]
+     let env1 = listToEnv [(getDeclName decl, sc) | (sc,decl) <- es ]
+     (implPs, implEnv) <- tiImpls (env1 `joinEnv` env) is
+     explPsEnv   <- mapM (tiExpl (implEnv `joinEnv` env1 `joinEnv` env)) es 
+     let explPs = concat [ x | (_,x,_) <- explPsEnv]
+     let explEnv = joinListEnvs $ [ x | (_,_,x) <- explPsEnv]
+     --let env2 = listToEnv [ assumpToPair (getDeclName decl :>: sc) | (sc,_,_) <- explPsEnv | (_,decl) <- es ]
+     let env2 = listToEnv [ (getDeclName decl,sc) | (sc,_,_) <- explPsEnv | (_,decl) <- es ]
+     return (implPs ++ explPs, env2 `joinEnv` explEnv `joinEnv` implEnv)
+
+tiSeq ti env []
+ = return ([],emptyEnv)
+tiSeq ti env (bs:bss)
+ = do (ps,env1)  <- ti env bs
+      (qs,env2) <- tiSeq ti (env1 `joinEnv` env) bss
+      return (ps++qs, env2 `joinEnv` env1)
+
+-----------------------------------------------------------------------------
+
+-- create a Program structure from a list of decls and
+-- type sigs. Type sigs are associated with corresponding
+-- decls if they exist
+
+getFunDeclsBg :: SigEnv -> [HsDecl] -> Program
+getFunDeclsBg sigEnv decls
+   = makeProgram sigEnv equationGroups
+   where
+   equationGroups :: [[HsDecl]]
+   equationGroups = getBindGroups bindDecls getDeclName getDeclDeps
+   --equationGroups = getBindGroups bindDecls (hsNameIdent_u (hsIdentString_u ("equationGroup" ++)) . getDeclName) getDeclDeps
+   -- just make sure we only deal with bindDecls and not others
+   bindDecls = collectBindDecls decls
+
+makeProgram :: SigEnv -> [[HsDecl]] -> Program
+makeProgram sigEnv groups
+   = map (makeBindGroup sigEnv ) groups
+
+
+-- reunite decls with their signatures, if ever they had one
+ 
+makeBindGroup :: SigEnv -> [HsDecl] -> BindGroup
+makeBindGroup sigEnv decls = (exps, impls) where
+   (exps, impls) = makeBindGroup' sigEnv decls
+
+makeBindGroup' _ [] = ([], [])
+makeBindGroup' sigEnv (d:ds)
+   = case Map.lookup funName sigEnv of
+        Nothing -- no type sig for this equation
+           -> (restExpls, d:restImpls)
+        Just scheme  -- this one has a type sig
+           -> ((scheme, d):restExpls, restImpls) 
+   where
+   funName = getDeclName d
+   (restExpls, restImpls) = makeBindGroup' sigEnv ds
+
+collectBindDecls :: [HsDecl] ->  [HsDecl]
+collectBindDecls = filter isBindDecl
+
+-----------------------------------------------------------------------------
+
+type Program = [BindGroup]
+
+tiProgram ::  Module -> SigEnv -> KindEnv -> ClassHierarchy -> TypeEnv -> TypeEnv -> Program -> IO TypeEnv
+tiProgram modName sEnv kt h dconsEnv env bgs = runTI dconsEnv h kt sEnv modName $
+  do (ps, env1) <- tiSeq tiBindGroup env bgs 
+     s         <- getSubst
+     ([], rs) <- split h [] (apply s ps)
+     case topDefaults h rs of
+       Right s' -> return $  apply ( s'@@s)  env1 
+       --Nothing -> return $  apply  s env1 
+       Left s -> fail $ show modName ++ s
+
+
+--------------------------------------------------------------------------------
+
+-- Typing Literals 
+
+tiLit            :: HsLiteral -> TI ([Pred],Type)
+tiLit (HsChar _) = return ([], tChar)
+tiLit (HsInt _)  
+   = do 
+        v <- newTVar Star
+        return ([IsIn classNum v], v)
+
+tiLit (HsFrac _) 
+   = do 
+        v <- newTVar Star
+        return ([IsIn classFractional v], v)
+
+tiLit (HsString _)  = return ([], tString)
+
+--------------------------------------------------------------------------------
+
+-- Typing Patterns
+
+tiPat :: HsPat -> TI ([Pred], Env Scheme, Type)
+
+tiPat (HsPVar i) = do 
+        v <- newTVar Star
+        --let newAssump = assumpToPair $ makeAssump i (toScheme v)
+        let newAssump = (i,toScheme v)
+        return ([], unitEnv newAssump, v)
+
+tiPat (HsPLit l) 
+   = do 
+        (ps, t) <- tiLit l
+        return (ps, emptyEnv, t)
+
+-- 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 pat)
+   = tiPat pat
+
+tiPat (HsPInfixApp pLeft conName pRight)
+   = do
+        (psLeft, envLeft, tLeft)    <- tiPat pLeft
+        (psRight, envRight, tRight) <- tiPat pRight
+        t'                         <- newTVar Star
+        sc <- dConScheme conName
+        (qs :=> t) <-  freshInst sc
+        unify t (tLeft `fn` (tRight `fn` t'))
+        return (psLeft ++ psRight, envLeft `joinEnv` envRight, t')
+
+tiPat (HsPApp conName pats)
+   = do
+        (ps,env,ts) <- tiPats pats
+        t'         <- newTVar Star
+        sc <- dConScheme conName
+        (qs :=> t) <- freshInst sc
+        unify t (foldr fn t' ts)
+        return (ps++qs, env, t') 
+
+tiPat tuple@(HsPTuple pats)
+   = do
+        (ps, env, ts) <- tiPats pats 
+        return (ps, env, tTTuple ts) 
+
+tiPat (HsPList [])
+   = do
+        v <- newTVar Star
+        return ([], emptyEnv, TAp tList v)
+
+tiPat (HsPList pats@(_:_))
+   = do
+        (ps, env, ts) <- tiPats pats
+        unifyList ts
+        return (ps, env, TAp tList (head ts))
+
+tiPat HsPWildCard
+ = do v <- newTVar Star
+      return ([], emptyEnv, v)
+
+tiPat (HsPAsPat i pat)
+ = do (ps, env, t) <- tiPat pat 
+      --let newAssump = makeAssump i $ toScheme t
+      --let newEnv = addToEnv (assumpToPair newAssump) env
+      let newEnv = addToEnv (i,toScheme t) env
+      return (ps, newEnv, t)
+
+tiPat (HsPIrrPat p)
+ = tiPat p
+
+tiPat (HsPParen p)
+ = tiPat p 
+
+tiPats :: [HsPat] -> TI ([Pred], Env Scheme, [Type])
+tiPats pats =
+  do psEnvts <- mapM tiPat pats
+     let ps = [ p | (ps,_,_) <- psEnvts, p<-ps ]
+         env = joinListEnvs $ map snd3 psEnvts
+         ts = [ t | (_,_,t) <- psEnvts ]
+     return (ps, env, ts)
addfile ./FrontEnd/TIModule.hs
hunk ./FrontEnd/TIModule.hs 1
+module TIModule (tiModules', TiData(..)) where
+
+import Atom
+import Char
+import Class   
+import Control.Monad.Writer
+import DataConsAssump     (dataConsEnv)
+import DeclsDepends       (getDeclDeps, debugDeclBindGroups)
+import DependAnalysis     (getBindGroups)
+import DerivingDrift.Drift
+import FrontEnd.Desugar           
+import FrontEnd.Env  as Env    
+import FrontEnd.Infix
+import FrontEnd.Rename     
+import GenUtil
+import Ho
+import DataConstructors
+import HsSyn 
+import IO
+import KindInfer
+import List
+import Monad
+import MonoidUtil
+import MultiModuleBasics  
+import Name
+import Name(toName)
+import Options
+import qualified FlagDump as FD
+import qualified HsPretty
+import qualified Data.Map as Map
+import qualified Data.Map as M
+import qualified Name
+import qualified PPrint 
+import Representation
+import TIMain             
+import TypeSigs           (collectSigs, listSigsToSigEnv)
+import TypeSynonyms
+import TypeSyns
+import Utils 
+import Warning
+import GenUtil
+
+trimEnv env = (listToEnv [ n | n@(name,_) <- envToList env,  isGlobal name ])
+trimMapEnv env = (Map.fromAscList [ n | n@(name,_) <- Map.toAscList env,  isGlobal name ])
+--------------------------------------------------------------------------------
+
+
+-- Extra data produced by the front end, used to fill in the Ho file.
+data TiData = TiData {
+    tiDataLiftedInstances :: M.Map HsName HsDecl,
+    tiDataModules :: [(Module,HsModule)],
+    tiModuleOptions :: [(Module,Opt)],
+    tiAllAssumptions :: Map.Map Name Scheme
+}
+
+isGlobal (Qual _ x) =  not $ isDigit $ head (hsIdentString x)
+isGlobal _ = error "isGlobal"
+
+modInfoDecls = hsModuleDecls . modInfoHsModule
+
+getImports ModInfo { modInfoHsModule = mod }  = [  (hsImportDeclModule x) | x <-  hsModuleImports mod]
+
+--lookupMod ModEnv { modEnvModules  = m } s =  case  M.lookup s m of
+--    Just z -> z
+--    Nothing -> error $ "lookupMod: " ++ show s
+    
+                            
+--buildFieldLabelMap ::  Map.Map Name (SrcLoc,[Name]) -> Map.Map Name [(Name,Int,Int)]
+--buildFieldLabelMap fm = Map.fromList $ sortGroupUnderF fst $ concat [ [ (y,(x,i,length ys)) |  y <- ys | i <- [0..] ]  | (x,(_,ys)) <- Map.toList fm, nameType x == DataConstructor ]
+
+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 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 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 
+    zmod' <-  driftDerive (modInfoHsModule m)
+    let mod = desugarHsModule (zmod') -- only needed for pattern bindings.. or is it?
+        --is = getImports m ++ if optPrelude options then [Module "Prelude"] else []
+        --(es,ts) = mconcat [ modInfoExports (lookupMod me i) | i <- is]
+        --(mod', errs) =  renameTidyModule (modEnvTypeSynonyms me) (fsts es) (fsts ts)  mod
+        -- we pass in the imported infix decls and also the ones from the local module
+        --renamedTidyModule'' = Infix.infixer (tidyInFixDecls (tidyModule renamedTidyModule') ++ modEnvFixities me) (tidyModule renamedTidyModule')
+        --(mod',errs) = runWriter $ renameModule (modEnvTypeSynonyms me) (modInfoImport m)  mod
+    let (mod',errs) = runWriter $ renameModule defs (modInfoImport m)  mod
+        mod'' = mod'
+        --mod'' = Infix.infixHsModule ( [ d | d <- hsModuleDecls mod', isHsInfixDecl d] ++ modEnvFixities me) ( mod')
+
+    when (dump FD.Renamed) $
+         do {putStrLn " \n ---- renamed code ---- \n";
+             putStrLn $ HsPretty.render 
+                      $ HsPretty.ppHsModule 
+                      $  mod''}
+    processErrors errs
+    return $ modInfoHsModule_s mod'' m
+    
+
+shwartz f xs = [ (f x, x) | x <- xs ]
+
+-- 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 ]
+
+tiModules' ::  Ho -> [ModInfo] -> IO (Ho,TiData)
+tiModules' me ms = do
+    let importVarEnv = Env.fromList [ (n,y) | (x,y) <- Map.toList $ hoAssumps me, let (t,n) = fromName x, t == Name.Val ]
+        importDConsEnv = Env.fromList [ (n,y) | (x,y) <- Map.toList $ hoAssumps me, let (t,n) = fromName x, t == Name.DataConstructor ]
+        importClassHierarchy = hoClassHierarchy me
+        importKindEnv = hoKinds me
+    wdump FD.Progress $ do
+        putErrLn $ "Typing: " ++ show ([ m | Module m <- map modInfoName ms])
+    let fieldMap = buildFieldMap me ms
+    ms <- mapM (processModule fieldMap) ms
+    let thisFixityMap = buildFixityMap (concat [ filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]) 
+    let fixityMap = thisFixityMap `mappend` hoFixities me
+    let thisTypeSynonyms =  (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])
+    let ts = thisTypeSynonyms  `mappend` hoTypeSynonyms me
+    let f x = expandTypeSyns ts (modInfoHsModule x) >>= FrontEnd.Infix.infixHsModule fixityMap >>= \z -> return (modInfoHsModule_s ( z) x)
+    ms <- mapM f ms 
+    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]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls  
+    --print (importKindEnv, classAndDataDecls)
+
+    wdump FD.Progress $ do
+        putErrLn $ "Kind inference"
+    kindInfo <- kiDecls importKindEnv classAndDataDecls
+
+    when (dump FD.Kind) $
+         do {putStrLn " \n ---- kind information ---- \n";
+             --mapM_ (putStrLn . show) (envToList kindInfo);
+             putStr $ PPrint.render $ pprintEnvMap kindInfo}
+
+    -- collect types for data constructors
+
+    let localDConsEnv = dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
+
+    when  (dump FD.Dcons) $
+         do {putStr "\n ---- data constructor assumptions ---- \n";
+             putStrLn $ PPrint.render $ pprintEnv localDConsEnv}
+
+
+    let globalDConsEnv = localDConsEnv `joinEnv` importDConsEnv
+
+    -- generate the class hierarchy skeleton
+
+    --classHierarchy  <- foldM (flip (addClassToHierarchy kindInfo)) importClassHierarchy ds -- ds -- rClassDecls
+    --cHierarchyWithInstances <- addInstancesToHierarchy kindInfo classHierarchy ds -- (rInstDecls ++ rDataDecls)
+
+    smallClassHierarchy <- makeClassHierarchy importClassHierarchy kindInfo ds
+    cHierarchyWithInstances <- return $ 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)]
+        --ca = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ++ instAssumps ] 
+        --ca' = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ] 
+        instanceEnv   = Map.fromList $ [ (x,y) | (x :>: y) <-  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 $ PPrint.render $ pprintEnvMap instanceEnv
+
+
+    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl] 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 ---- ";
+             --mapM_ (putStrLn . show) (envToList kindInfo);
+             putStrLn $ PPrint.render $ pprintEnvMap sigEnv}
+    let bindings = (funPatBinds ++ [ z | z <- cDefBinds, isHsFunBind z || isHsPatBind z] ++ liftedInstances)
+        classDefaults  = snub [ getDeclName z | z <- cDefBinds, isHsFunBind z || isHsPatBind z ]
+        classNoDefaults = snub (concat [ getDeclNames z | z <- cDefBinds ])  List.\\ classDefaults
+        noDefaultSigs = Env.fromList [ (n,maybe (error $ "sigEnv:"  ++ show n) id $ Map.lookup n sigEnv) | n <- classNoDefaults ]
+        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc ForeignPrimitive "" x (HsUnQualType $ HsTyTuple []) ] | (x,_) <- Env.toList noDefaultSigs]
+    --when verbose2 $ putStrLn (show bindings)
+    let programBgs   
+           = getBindGroups bindings 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 ( fakeForeignDecls ++ programBgs )
+    when (dump FD.Program) $ do 
+        putStrLn " ---- Program ---- "
+        mapM_ putStrLn $ map (PPrint.render . PPrint.pprint) $  program
+
+    -- type inference/checking for all variables
+
+    wdump FD.Progress $ do
+        putErrLn $ "Type inference"
+    let moduleName = modInfoName (head ms) 
+    localVarEnv <- tiProgram 
+                moduleName                     -- name of the module
+                sigEnv                         -- environment of type signatures
+                kindInfo                       -- kind information about classes and type constructors
+                cHierarchyWithInstances        -- class hierarchy with instances
+                globalDConsEnv                 -- data constructor type environment 
+                (importVarEnv  )               -- type environment
+                program                        -- binding groups
+
+
+    when (dump FD.Types) $
+         do {putStrLn " ---- the types of identifiers ---- ";
+             putStrLn $ PPrint.render $ pprintEnv (if verbose2 then localVarEnv else trimEnv localVarEnv) }
+
+    let externalEnv = Env.fromList [ v | v@(x@(Qual m i) ,s) <- Env.toList localVarEnv, isGlobal x, m `elem` map modInfoName ms ]  `joinFM` noDefaultSigs
+    localVarEnv <- return $  localVarEnv `joinFM` noDefaultSigs
+    let externalKindEnv = Map.fromList [ v | v@(x@(Qual m i) ,s) <- Map.toList kindInfo, isGlobal x, m `elem` map modInfoName ms ]  
+
+    let pragmaProps = M.fromListWith (\a b -> snub $ a ++ b ) [ (toName Name.Val x,[toAtom w]) |  HsPragmaProps _ w xs <- ds, x <- xs ]
+    
+    let allAssumps = M.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Env.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Env.toList localVarEnv ]
+        --expAssumps = M.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Env.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Env.toList $ trimEnv localVarEnv ]
+        expAssumps = M.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Env.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Env.toList $ externalEnv ]
+    let ho = mempty {
+        hoExports = M.fromList [ (modInfoName m,modInfoExport m) | m <- ms ],
+        hoDefs =  M.fromList [ (x,(y,z)) | (x,y,z) <- concat $ map modInfoDefs ms],
+        hoAssumps = expAssumps,
+        hoFixities = thisFixityMap,
+        --hoKinds = trimMapEnv kindInfo,
+        hoKinds = externalKindEnv,
+        --hoClassHierarchy = cHierarchyWithInstances,
+        hoClassHierarchy = smallClassHierarchy,
+        hoProps = pragmaProps,
+        hoTypeSynonyms = thisTypeSynonyms
+        
+        }
+        tiData = TiData {
+            tiDataLiftedInstances = M.fromList [ (getDeclName d,d) | d <- liftedInstances],
+            tiDataModules = [ (modInfoName m, modInfoHsModule m) |  m <- ms],
+            tiModuleOptions = [ (modInfoName m, modInfoOptions m) |  m <- ms],
+            tiAllAssumptions = allAssumps
+        }
+    return (ho,tiData)
+    {-
+    let me''' = 
+            addItems modEnvVarAssumptions_u (trimEnv localVarEnv) . 
+            addItems modEnvDConsAssumptions_u localDConsEnv .
+            addItems modEnvAllAssumptions_u allAssumps . 
+            addItems modEnvKinds_u (trimMapEnv kindInfo) . 
+            modEnvTypeSynonyms_s ts . --  (++ [ d | d <- ds, isHsTypeDecl d ]) . 
+            modEnvClassHierarchy_s cHierarchyWithInstances .
+            modEnvLiftedInstances_u (M.union $ M.fromList [ (getDeclName d,d) | d <- liftedInstances]) .
+            --modEnvFixities_u (++ [ d | d <- ds, isHsInfixDecl d ])  
+            modEnvFixities_s fixityMap  
+            $ me''
+    --let mi = ModuleInfo { varAssumps = localVarEnv, dconsAssumps = localDConsEnv, 
+    --                    classHierarchy = cHierarchyWithInstances, kinds = kindInfo, infixDecls = getInfixDecls mod, 
+    --                    tyconsMembers = getTyconsMembers mod, synonyms = tidyTyDecls tidyMod, 
+    --                    renamedModule =  [addDecls mod liftedInstances]}
+    return me'''
+
+tiModules ::  ModEnv -> [ModInfo] -> IO ModEnv
+tiModules me ms = do
+    let importVarEnv = modEnvVarAssumptions me
+        importDConsEnv = modEnvDConsAssumptions me
+        importClassHierarchy = modEnvClassHierarchy me
+        importKindEnv = modEnvKinds me
+    wdump FD.Progress $ do
+        putErrLn $ "Typing: " ++ show ([ m | Module m <- map modInfoName ms])
+
+    let me' = modEnvModules_u (M.union (M.fromList (shwartz modInfoName ms))) me
+    ms <- mapM (processModule me') ms
+    let fixityMap = buildFixityMap (concat [ filter isHsInfixDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms]) `mappend` modEnvFixities me
+    let ts = (declsToTypeSynonyms $ concat [ filter isHsTypeDecl (hsModuleDecls $ modInfoHsModule m) | m <- ms])  `mappend` modEnvTypeSynonyms me
+    let f x = expandTypeSyns ts (modInfoHsModule x) >>= FrontEnd.Infix.infixHsModule fixityMap >>= \z -> return (modInfoHsModule_s ( z) x)
+    ms <- mapM f ms 
+    let me'' = modEnvModules_u (M.union (M.fromList (shwartz modInfoName ms))) me'
+    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]) ds  -- rDataDecls ++ rNewTyDecls ++ rClassDecls  
+    --print (importKindEnv, classAndDataDecls)
+
+    wdump FD.Progress $ do
+        putErrLn $ "Kind inference"
+    kindInfo <- kiDecls importKindEnv classAndDataDecls
+
+    when (dump FD.Kind) $
+         do {putStrLn " \n ---- kind information ---- \n";
+             --mapM_ (putStrLn . show) (envToList kindInfo);
+             putStr $ PPrint.render $ pprintEnvMap kindInfo}
+
+    -- collect types for data constructors
+
+    let localDConsEnv = dataConsEnv (error "modName") kindInfo classAndDataDecls -- (rDataDecls ++ rNewTyDecls)
+
+    when  (dump FD.Dcons) $
+         do {putStr "\n ---- data constructor assumptions ---- \n";
+             putStrLn $ PPrint.render $ pprintEnv localDConsEnv}
+
+
+    let globalDConsEnv = localDConsEnv `joinEnv` importDConsEnv
+
+    -- generate the class hierarchy skeleton
+
+    classHierarchy  <- foldM (flip (addClassToHierarchy kindInfo)) importClassHierarchy ds -- ds -- rClassDecls
+    cHierarchyWithInstances <- addInstancesToHierarchy kindInfo classHierarchy ds -- (rInstDecls ++ rDataDecls)
+    when (dump FD.ClassSummary) $ do
+        putStrLn "  ---- class summary ---- "
+        printClassSummary cHierarchyWithInstances
+
+    when (dump FD.Class) $
+         do {putStrLn "  ---- class hierarchy ---- ";
+             printClassHierarchy cHierarchyWithInstances}
+
+    -- 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)]
+        --ca = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ++ instAssumps ] 
+        --ca' = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ] 
+        instanceEnv   = Map.fromList $ [ (x,y) | (x :>: y) <-  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 $ PPrint.render $ pprintEnvMap instanceEnv
+
+
+    let funPatBinds =  [ d | d <- ds, or' [isHsFunBind, isHsPatBind, isHsForeignDecl] 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 ---- ";
+             --mapM_ (putStrLn . show) (envToList kindInfo);
+             putStrLn $ PPrint.render $ pprintEnvMap sigEnv}
+    let bindings = (funPatBinds ++ [ z | z <- cDefBinds, isHsFunBind z || isHsPatBind z] ++ liftedInstances)
+        classDefaults  = snub [ getDeclName z | z <- cDefBinds, isHsFunBind z || isHsPatBind z ]
+        classNoDefaults = snub (concat [ getDeclNames z | z <- cDefBinds ])  List.\\ classDefaults
+        noDefaultSigs = Env.fromList [ (n,Map.find n sigEnv) | n <- classNoDefaults ]
+        fakeForeignDecls = [ [HsForeignDecl bogusASrcLoc ForeignPrimitive "" x (HsUnQualType $ HsTyTuple []) ] | (x,_) <- Env.toList noDefaultSigs]
+    --when verbose2 $ putStrLn (show bindings)
+    let programBgs   
+           = getBindGroups bindings 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 ( fakeForeignDecls ++ programBgs )
+    when (dump FD.Program) $ do 
+        putStrLn " ---- Program ---- "
+        mapM_ putStrLn $ map (PPrint.render . PPrint.pprint) $  program
+
+    -- type inference/checking for all variables
+
+    wdump FD.Progress $ do
+        putErrLn $ "Type inference"
+    let moduleName = modInfoName (head ms) 
+    localVarEnv <- tiProgram 
+                moduleName                     -- name of the module
+                sigEnv                         -- environment of type signatures
+                kindInfo                       -- kind information about classes and type constructors
+                cHierarchyWithInstances        -- class hierarchy with instances
+                globalDConsEnv                 -- data constructor type environment 
+                (importVarEnv  )               -- type environment
+                program                        -- binding groups
+
+
+    when (dump FD.Types) $
+         do {putStrLn " ---- the types of identifiers ---- ";
+             putStrLn $ PPrint.render $ pprintEnv (if verbose2 then localVarEnv else trimEnv localVarEnv) }
+
+    localVarEnv <- return $  localVarEnv `joinFM` noDefaultSigs
+    
+    let allAssumps = M.fromList $ [ (toName Name.DataConstructor x,y) | (x,y) <- Env.toList localDConsEnv ] ++ [ (toName Name.Val x,y) | (x,y) <- Env.toList localVarEnv ]
+    let me''' = 
+            addItems modEnvVarAssumptions_u (trimEnv localVarEnv) . 
+            addItems modEnvDConsAssumptions_u localDConsEnv .
+            addItems modEnvAllAssumptions_u allAssumps . 
+            addItems modEnvKinds_u (trimMapEnv kindInfo) . 
+            modEnvTypeSynonyms_s ts . --  (++ [ d | d <- ds, isHsTypeDecl d ]) . 
+            modEnvClassHierarchy_s cHierarchyWithInstances .
+            modEnvLiftedInstances_u (M.union $ M.fromList [ (getDeclName d,d) | d <- liftedInstances]) .
+            --modEnvFixities_u (++ [ d | d <- ds, isHsInfixDecl d ])  
+            modEnvFixities_s fixityMap  
+            $ me''
+    --let mi = ModuleInfo { varAssumps = localVarEnv, dconsAssumps = localDConsEnv, 
+    --                    classHierarchy = cHierarchyWithInstances, kinds = kindInfo, infixDecls = getInfixDecls mod, 
+    --                    tyconsMembers = getTyconsMembers mod, synonyms = tidyTyDecls tidyMod, 
+    --                    renamedModule =  [addDecls mod liftedInstances]}
+    return me'''
+    
+addItems mu env = mu (mappend env)
+    -}
+    
+{-
+{-# NOINLINE tiModule #-}
+tiModule dumps modSyntax imports = do 
+    let importVarEnv = varAssumps imports
+        importDConsEnv = dconsAssumps imports
+        importClassHierarchy = classHierarchy imports
+        importKindEnv = kinds imports
+        importSynonyms = synonyms imports
+        importTyconMembers = tyconsMembers imports
+
+    let moduleName = hsModuleName modSyntax
+    let tidyMod = tidyModule modSyntax
+    -- make all pattern bindings simple and remove type synonyms, convert do-notation into expression form
+    let desugaredTidyModule = desugarTidyModule importSynonyms tidyMod
+    when (doDump dumps "desugar") $
+         do {putStrLn "\n\n ---- desugared code ---- \n\n";
+             putStrLn $ HsPretty.render 
+                      $ HsPretty.ppHsModule 
+                      $ tidyModuleToHsModule desugaredTidyModule}
+    -- uniquely rename variables and generate a table of information about identifiers
+
+        -- TODO: we probably need to worry about synonyms and 
+        --       the like as well but at the moment we can live
+        --       with vars and datacons only.
+    let 
+        importVarEnv' = trimEnv $ importVarEnv 
+        isGlobal (Qual _ x) =  not $ isDigit $ head (hsIdentString x)
+        isGlobal _ = error "isGlobal"
+    let importedNames = getNamesFromEnv importVarEnv' 
+                     ++ getNamesFromEnv importDConsEnv
+                     ++ getNamesFromTycons importTyconMembers
+                     ++ getNamesFromEnv importClassHierarchy 
+                     ++ [ n | (n :>: _) <- classAssumps ]
+                     ++ getNamesFromEnv importKindEnv         
+                    --  ++ getNamesFromInfix  -- shouldn't need this as we get
+                    -- them as part of getting their types in the varEnv
+        -- because we need to know to rename True to Prelude.True
+        -- as well, and this is a convenient way to do it:
+        classAssumps = concat  [ as | (_,_,as) <- (eltsFM importClassHierarchy)]
+        getNamesFromTycons :: [(HsName, [HsName])] -> [HsName]
+        getNamesFromTycons = concatMap snd 
+
+    putVerbose $ show (namesHsModule (tidyModuleToHsModule desugaredTidyModule))
+    let (renamedTidyModule', errs) =  renameTidyModule importSynonyms (filter isGlobal importedNames) (filter isGlobal importedNames) (tidyModuleToHsModule desugaredTidyModule)
+        -- we pass in the imported infix decls and also the ones from the local module
+        renamedTidyModule'' = Infix.infixer (tidyInFixDecls (tidyModule renamedTidyModule') ++ infixDecls imports) (tidyModule renamedTidyModule')
+
+    let renamedTidyModule =  renamedTidyModule''
+
+    when (doDump dumps "desugar") $
+         do {putStrLn "\n\n ---- desugared code ---- \n\n";
+             putStrLn $ HsPretty.render 
+                      $ HsPretty.ppHsModule 
+                      $ tidyModuleToHsModule desugaredTidyModule}
+
+    -- All the names are getting qualified but they are unqualified by fromHsModule
+    processErrors errs
+
+    when (doDump dumps "renamed") $
+         do {putStrLn " \n\n ---- renamed code ---- \n\n";
+             putStrLn $ HsPretty.render 
+                      $ HsPretty.ppHsModule 
+                      $ tidyModuleToHsModule renamedTidyModule}
+
+
+    -- separate the renamed decls apart
+    let --rTyDecls    = tidyTyDecls    renamedTidyModule 
+        rDataDecls  = tidyDataDecls  renamedTidyModule 
+        rNewTyDecls = tidyNewTyDecls renamedTidyModule 
+        rClassDecls = tidyClassDecls renamedTidyModule 
+        rInstDecls  = tidyInstDecls  renamedTidyModule 
+        rTySigs     = tidyTySigs     renamedTidyModule 
+        rFunBinds   = tidyFunBinds   renamedTidyModule 
+        rPatBinds   = tidyPatBinds   renamedTidyModule 
+
+
+    -- collect all the type signatures from the module (this must be done after renaming)
+
+        --   = getBindGroups (rFunBinds ++ rPatBinds ++ cDefBinds ++ liftedInstances) getDeclName getDeclDeps
+
+    -- kind inference for all type constructors type variables and classes in the module
+
+    let classAndDataDecls = rDataDecls ++ rNewTyDecls ++ rClassDecls 
+
+    let kindInfo = kiModule (trimEnv importKindEnv) classAndDataDecls
+
+    when (doDump dumps "kinds") $
+         do {putStrLn " \n\n ---- kind information ---- \n\n";
+             putStr $ PPrint.render $ pprintEnv kindInfo}
+
+
+-- collect types for data constructors
+
+    let localDConsEnv = dataConsEnv moduleName kindInfo (rDataDecls ++ rNewTyDecls)
+
+    when (doDump dumps "dconstypes") $
+         do {putStr "\n\n ---- data constructor assumptions ---- \n\n";
+             putStrLn $ PPrint.render $ pprintEnv localDConsEnv}
+
+
+    let globalDConsEnv = localDConsEnv `joinEnv` importDConsEnv
+
+-- generate the class hierarchy skeleton
+
+    let classHierarchy = foldl (flip (addClassToHierarchy moduleName kindInfo)) importClassHierarchy rClassDecls
+    let cHierarchyWithInstances 
+            = addInstancesToHierarchy kindInfo classHierarchy (rInstDecls ++ rDataDecls)
+    when (doDump dumps "classes") $
+         do {putStrLn " \n\n ---- class hierarchy ---- \n\n";
+             printClassHierarchy cHierarchyWithInstances}
+
+ -- lift the instance methods up to top-level decls
+
+    let myClassAssumps = concat  [ as | (_,_,as) <- (eltsFM cHierarchyWithInstances)]
+        ca = listToEnv $ [ (x,y) | (x :>: y) <- myClassAssumps  ++ instAssumps ] 
+    --print ca
+        (liftedInstances,instAssumps) = unzip $ concatMap (instanceToTopDecls kindInfo cHierarchyWithInstances) rInstDecls
+
+
+    when (not (null liftedInstances) &&  doDump dumps "instances") $
+       do {putStrLn " \n\n ---- lifted instance declarations ---- \n\n";
+           putStr $ unlines $ 
+              map (HsPretty.render . HsPretty.ppHsDecl) liftedInstances}
+
+
+-- build an environment of assumptions for all the type signatures
+    let cDefBinds = concat [ [ z | z <- ds] | HsClassDecl _ _ ds <- rClassDecls]
+    let allTypeSigs = (collectSigs (rFunBinds ++ rPatBinds {- ++ cDefBinds -} ++ liftedInstances)) ++ rTySigs
+
+    when (doDump dumps "srcsigs") $
+         do {putStrLn " \n\n ---- type signatures from source code (after renaming) ---- \n\n";
+             putStr $ unlines $ map (HsPretty.render . HsPretty.ppHsDecl) allTypeSigs}
+                                             
+    let sigEnv = listSigsToSigEnv kindInfo allTypeSigs `joinEnv` ca
+
+-- binding groups for top-level variables
+    let programBgs 
+           = getBindGroups (rFunBinds ++ rPatBinds ++ [ z | z <- cDefBinds, isHsFunBind z || isHsPatBind z] ++ liftedInstances) getDeclName getDeclDeps
+           
+
+    when (doDump dumps "varbindgroups") $
+         do {putStrLn " \n\n ---- toplevel variable binding groups ---- ";
+             putStrLn " ---- Bindgroup # = [members] [vars depended on] [missing vars] ---- \n";
+             putStr $ debugDeclBindGroups programBgs}
+
+    let program = makeProgram sigEnv programBgs
+
+-- type inference/checking for all variables
+
+    when (doDump dumps "types") $
+         do {putStr "\n\n ---- the types of identifiers assumed... ---- \n\n";
+             putStrLn $ PPrint.render $ pprintEnv (importVarEnv' `joinEnv` ca )}
+
+
+
+
+    let localVarEnv = tiProgram 
+                moduleName                     -- name of the module
+                sigEnv                         -- environment of type signatures
+                kindInfo                       -- kind information about classes and type constructors
+                cHierarchyWithInstances        -- class hierarchy with instances
+                globalDConsEnv                 -- data constructor type environment 
+                (importVarEnv' `joinEnv` ca )  -- type environment
+                program                        -- binding groups
+
+
+    when (doDump dumps "types") $
+         do {putStr "\n\n ---- the types of identifiers ---- \n\n";
+             putStrLn $ PPrint.render $ pprintEnv localVarEnv}
+
+    let mod = tidyModuleToHsModule renamedTidyModule
+
+    let mi = ModuleInfo { varAssumps = localVarEnv, dconsAssumps = localDConsEnv, 
+                        classHierarchy = cHierarchyWithInstances, kinds = kindInfo, infixDecls = getInfixDecls mod, 
+                        tyconsMembers = getTyconsMembers mod, synonyms = tidyTyDecls tidyMod, 
+                        renamedModule =  [addDecls mod liftedInstances]}
+
+    return mi
+ -}
addfile ./FrontEnd/TIMonad.hs
hunk ./FrontEnd/TIMonad.hs 1
+{-# OPTIONS -fglasgow-exts #-}
+
+{-------------------------------------------------------------------------------
+
+        Copyright:              Mark Jones and The Hatchet Team 
+                                (see file Contributors)
+
+        Module:                 TIMonad
+
+        Description:            A monad to support type inference, in 
+                                particular for threading the type environment
+                                through the type inference code.
+
+        Primary Authors:        Mark Jones, Bernie Pope and Bryn Humberstone
+
+        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 TIMonad (TI, 
+                inst,
+                runTI,
+                getErrorContext, 
+                --pushErrorContext, 
+                withContext,
+                --popErrorContext,
+                -- DCAssumpTable,
+                getSubst,
+                getClassHierarchy,
+                getKindEnv,
+                getSigEnv,
+                unify,
+                freshInst,
+                dConScheme,
+                unifyList,
+                getModName,
+                newTVar) where
+
+import HsSyn    
+import Diagnostic
+import Representation
+import Type                  ((@@), Types (..), Instantiate (..), nullSubst, mgu)
+import Class                 (ClassHierarchy)
+import FrontEnd.Env
+import KindInfer             (KindEnv)
+import TypeSigs              (SigEnv)
+import PPrint                (pretty)
+import Monad
+import Control.Monad.State hiding(State(..))
+import Atom
+import Utils
+import Data.IORef
+import VConsts
+import Warning
+--import Control.Monad.Reader
+
+--------------------------------------------------------------------------------
+
+
+
+-- read only environment, set up before type checking.
+data TcEnv = TcEnv {
+      tcClassHierarchy    :: ClassHierarchy,
+      tcKinds             :: KindEnv,
+      tcModuleName        :: Module,
+      tcDiagnostics       :: [Diagnostic],   -- list of information that might help diagnosis
+      tcVarnum            :: IORef Int,
+      tcSubst             :: IORef Subst,
+      tcDConsEnv          :: Env Scheme,
+      tcSigs              :: SigEnv
+    } 
+   {-! derive: update !-}
+
+
+--newtype TI a = TI (TcEnv -> State -> (# a, State #))
+newtype TI a = TI (TcEnv -> IO a)
+
+--instance MonadState State TI where 
+--    {-# INLINE get #-}
+--    {-# INLINE put #-}
+--    get = TI (\_ s -> (# s,s #))
+--    put s = TI (\_ _ -> (# (),s #))
+--    get = TI (\s -> readIORef (tcState s))
+--    put s = TI (\v -> writeIORef (tcState v) $! s)
+
+--instance MonadReader TcEnv TI  where
+{-# INLINE ask #-}
+{-# INLINE local #-}
+{-# INLINE asks #-}
+
+ask = TI (\t -> return t)
+local f (TI c) = TI (\t -> c (f t))
+asks f = liftM f ask 
+
+-- dcat == data constructor assump table
+
+instance Monad TI where
+    {-# INLINE return #-}
+    {-# INLINE (>>=) #-}
+    {-# INLINE (>>) #-}
+    return a = TI (\_ -> return a)
+    TI comp >>= fun = TI (\t -> comp t >>= \x -> case fun x of
+        TI r -> r t)
+    TI a >> TI b = TI (\t -> a t >> b t)
+    fail s = TI $ \st -> do
+        processIOErrors 
+        typeError (Failure s) (tcDiagnostics st)
+        -- fail s
+
+--    return a
+--        = TI (\_ state -> (# a, state #))    -- maintain state and return value
+--    TI comp >>= fun
+--        = TI (\e state -> case comp e state of  
+--            (# result, newState #) -> case fun result of  
+--                TI comp' -> comp' e newState)
+
+--    TI comp >>= fun
+--        = TI (\state -> let (result, newState) = comp state
+--                            TI comp' = fun result
+--                        in
+--                        if inerror newState then (undefined, newState)
+--                                            else comp' newState)
+-- we only continue with the calculations if there isn't an error
+
+instance Functor TI where
+    fmap = liftM
+
+runTI     :: Env Scheme-> ClassHierarchy -> KindEnv -> SigEnv -> Module -> TI a -> IO a
+runTI env' ch' kt' st' mod' (TI c) = do
+    vn <- newIORef 0
+    sub <- newIORef nullSubst
+    c tcenv {  tcVarnum = vn,  tcSubst = sub } where
+    tcenv = TcEnv {
+        tcClassHierarchy = ch',
+        tcKinds = kt',
+        tcModuleName = mod', 
+        tcSigs = st',
+        tcVarnum = undefined,
+        tcSubst = undefined,
+        tcDConsEnv = env',
+        tcDiagnostics = [Msg Nothing $ "Compilation of module: " ++ fromModule mod']
+        
+        }
+
+
+
+{- 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 -}
+{-# INLINE withContext #-}
+{-# INLINE tcDiagnostics_u #-}
+withContext :: Diagnostic -> TI a -> TI a
+withContext diagnostic comp = do 
+    local (tcDiagnostics_u (diagnostic:)) comp
+
+
+getErrorContext :: TI [Diagnostic]
+getErrorContext = asks tcDiagnostics
+
+
+getSubst :: TI Subst
+getSubst = TI $ \t -> readIORef (tcSubst t) -- gets subst
+
+getDConsTypeEnv :: TI (Env Scheme) 
+getDConsTypeEnv = TI $ \t -> return (tcDConsEnv t) -- gets env 
+
+getClassHierarchy  :: TI ClassHierarchy
+getClassHierarchy = asks tcClassHierarchy
+
+getKindEnv :: TI (KindEnv)
+getKindEnv = asks tcKinds
+
+getSigEnv :: TI SigEnv
+getSigEnv = asks tcSigs
+
+getModName :: TI Module
+getModName = asks tcModuleName
+
+
+dConScheme :: HsName -> TI Scheme 
+dConScheme conName
+   = do
+        env <- getDConsTypeEnv 
+        case lookupEnv conName env of
+           Nothing 
+            --  | Just n <- fromTupname conName -> return (toTuple n) 
+            | otherwise -> error $ "dConScheme: constructor not found: " ++ show conName ++
+                              "\nin this environment:\n" ++ show env
+           Just s -> return s
+
+unify      :: Type -> Type -> TI ()
+unify t1 t2 = do s <- getSubst
+                 let t1' = apply s t1
+                     t2' = apply s t2
+                 case mgu t1' t2' of
+                   Just u  -> extSubst u
+                   Nothing -> do
+                              diagnosis <- getErrorContext
+                              typeError (Unification $ "attempted to unify " ++ 
+                                                       pretty t1' ++
+                                                       " with " ++
+                                                       pretty t2')
+                                        diagnosis
+
+unifyList :: [Type] -> TI ()
+unifyList [] = return ()
+unifyList [_] = return ()
+unifyList (t1:t2:ts) = do
+       unify t1 t2
+       unifyList (t2:ts)
+
+{-
+trim       :: [Tyvar] -> TI ()
+trim vs     = TI (\state ->
+                     let s' = [(v,t) | (v,t) <- toListFM (subst state), v `elem` vs]
+                         force = length (tv (map snd s'))
+                     in force `seq` ((), state {subst = listToFM s'})
+                 )
+-}
+
+extSubst   :: Subst -> TI ()
+--extSubst s' = TI (\_ state -> (# (), state {subst = s'@@(subst state)} #))
+extSubst s' = TI (\t -> modifyIORef (tcSubst t) (s' @@))
+
+newTVar    :: Kind -> TI Type
+newTVar k   = TI $ \te -> do 
+                n <- readIORef (tcVarnum te)
+                let ident = Qual (tcModuleName te) $ HsIdent $ "v" ++ show n
+                    v = Tyvar (Atom.fromString $ fromHsName ident) ident k
+                writeIORef (tcVarnum te) $! n + 1
+                return $ TVar v
+                 
+--newTVar k   = TI (\te state -> 
+--                   let n = varnum state
+--                       ident = Qual (tcModuleName te) $ HsIdent $ "v" ++ show n
+--                       v = Tyvar (Atom.fromString $ fromHsName ident) ident k
+--                   in  (# TVar v, state{varnum = n+1} #)
+--                 )
+
+{-
+freshInt :: TI Int
+freshInt = TI (\state -> 
+                   let n = varnum state
+                   in  (n, state{varnum = n+1})
+                 )
+-}
+
+
+    
+
+freshInst :: Scheme -> TI (Qual Type)
+freshInst (Forall ks qt) = do 
+        ts <- mapM newTVar ks
+        let v = (inst ts qt)
+        return (v)
+
+
addfile ./FrontEnd/Type.hs
hunk ./FrontEnd/Type.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              Mark Jones and The Hatchet Team 
+                                (see file Contributors)
+
+        Module:                 Type
+
+        Description:            Manipulation of types
+
+                                The main tasks implemented by this module are:
+                                        - type substitution
+                                        - type unification
+                                        - type matching
+                                        - type quantification
+
+        Primary Authors:        Mark Jones and Bernie Pope
+
+        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 Type (kind,
+             nullSubst,
+             (@@),
+             Types (..),
+             (+->),
+             merge,
+             mgu,
+             match,
+             quantify,
+             unQuantify,
+             toScheme,
+             makeAssump,
+             assumpScheme,
+             assumpToPair,
+             pairToAssump,
+             assumpId,
+             tTTuple,
+             Instantiate (..)
+             ) where 
+
+import HsSyn   (HsName (..))
+import List    (union, nub)
+import Data.FiniteMap
+import FrontEnd.Env
+import Representation
+import Monad   (foldM)
+import VConsts
+
+
+--------------------------------------------------------------------------------
+
+class Types t where
+  apply :: Subst -> t -> t
+  tv    :: t -> [Tyvar]
+
+class Instantiate t where
+  inst  :: [Type] -> t -> t
+
+instance Instantiate Type where
+  inst ts (TAp l r)     = TAp (inst ts l) (inst ts r)
+  inst ts (TArrow l r)  = TArrow (inst ts l) (inst ts r)
+--  inst ts (TTuple args) = TTuple $ map (inst ts) args
+  inst ts t@(TGen n _)  | n < length ts = ts !! n
+                        | otherwise = error $ "inst TGen " ++ show (ts,t)
+  inst ts t             = t
+
+instance Instantiate a => Instantiate [a] where
+  inst ts = map (inst ts)
+
+instance Instantiate t => Instantiate (Qual t) where
+  inst ts (ps :=> t) = inst ts ps :=> inst ts t
+
+instance Instantiate Pred where
+  inst ts (IsIn c t) = IsIn c (inst ts t)
+
+class HasKind t where
+  kind :: t -> Kind
+instance HasKind Tyvar where
+  kind (Tyvar _ _ k) = k
+instance HasKind Tycon where
+  kind (Tycon v k) = k
+instance HasKind Type where
+  kind (TCon tc) = kind tc
+  kind (TVar u)  = kind u
+  kind (TAp t _) = case (kind t) of
+                     (Kfun _ k) -> k
+  kind (TArrow _l _r) = Star
+--  kind (TTuple _args) = Star
+  kind (TGen _ tv) = kind tv
+  --kind x = error $ "Type:kind: " ++ show x
+
+-----------------------------------------------------------------------------
+
+instance Types t => Types (Qual t) where
+  apply s (ps :=> t) = apply s ps :=> apply s t
+  tv (ps :=> t)      = tv ps `union` tv t
+
+instance Types Pred where
+  apply s (IsIn c t) = IsIn c (apply s t)
+  tv (IsIn c t)      = tv t
+
+--------------------------------------------------------------------------------
+
+-- substitutions
+
+nullSubst  :: Subst
+nullSubst   = zeroFM 
+
+(+->)      :: Tyvar -> Type -> Subst
+Tyvar u _ _ +-> t     = unitFM u t
+
+instance Types Type where
+  
+  -- attempting to cache successful substitutions doesn't
+  -- seem to make much difference, as the variables are 
+  -- mostly independent
+
+--  apply s (TVar var@(Tyvar name _kind)) 
+--     = case lookupSubstitutionMap s name of
+--          Just t  -> t
+--          Nothing -> TVar var 
+  apply s x@(TVar (Tyvar var _ _)) 
+     = case lookupFM s var of
+          Just t  -> t
+          Nothing -> x
+  apply s (TAp l r)     = TAp (apply s l) (apply s r)
+  apply s (TArrow l r)  = TArrow (apply s l) (apply s r)
+--  apply s (TTuple args) = TTuple $ map (apply s) args 
+  apply _ t         = t
+
+  tv (TVar u)      = [u]
+  tv (TAp l r)     = tv l `union` tv r
+  tv (TArrow l r)  = tv l `union` tv r 
+  -- tv (TTuple args) = concatMap tv args 
+--  tv (TTuple args) = foldl union [] $ map tv args 
+  tv _             = []
+
+instance Types a => Types [a] where
+  apply s = map (apply s)              -- it may be worth using a cached version of apply in this circumstance? 
+  tv      = nub . concat . map tv
+
+infixr 4 @@
+(@@)       :: Subst -> Subst -> Subst
+s1 @@ s2 
+   =(joinFM s1OverS2 s1)
+   where
+   s1OverS2 = mapSubstitution s1 s2 
+
+merge      :: Monad m => Subst -> Subst -> m Subst
+merge s1 s2 = if agree then return s else fail $ "merge: substitutions don't agree" 
+ where
+ s = joinFM s1 s2
+ agree = all (\v -> lookupFM s1 (v) == lookupFM s2 (v)) $ map fst $ toListFM $ s1 `intersectFM` s2
+-- agree = all (\v -> apply s1 (TVar v) == apply s2 (TVar v)) $ map fst $ toListFM $ s1 `intersectFM` s2
+
+-- highly specialised version of lookupFM for
+-- a Substitution. It is worth specialising this as it is called
+-- frequently during a call to apply
+-- according to profiling almost half of the computation time
+-- is spent here
+
+{-
+lookupSubstitutionMap :: FiniteMap Tyvar Type -> HsName -> Maybe Type
+lookupSubstitutionMap (Node (Tyvar k _kind) e _ sm gr) k'
+   | k' <  k    = lookupSubstitutionMap sm k' 
+   | k' >  k    = lookupSubstitutionMap gr k' 
+   | otherwise  = Just e
+lookupSubstitutionMap Leaf _
+   = Nothing
+-- specialised version of mapFM for substitutions
+
+mapSubstitution :: Subst -> FiniteMap Tyvar Type -> FiniteMap Tyvar Type 
+mapSubstitution s (Node k e n sm gr)  = Node k (apply s e) n (mapSubstitution s sm) (mapSubstitution s gr)
+mapSubstitution s Leaf                = Leaf
+-}
+
+
+mapSubstitution s fm =(mapFM (\_ v -> apply s v) fm)
+
+rnfFM fm = foldFM (\k e a -> k `seq` e `seq` a) () fm `seq` fm
+
+--------------------------------------------------------------------------------
+
+-- unification
+
+mgu     :: Monad m => Type -> Type -> m Subst
+varBind :: Monad m => Tyvar -> Type -> m Subst
+
+mgu (TAp l r) (TAp l' r') 
+   = do s1 <- mgu l l'
+        s2 <- mgu (apply s1 r) (apply s1 r')
+        return (s2 @@ s1)
+
+mgu (TArrow l r) (TArrow l' r')
+   = do s1 <- mgu l l' 
+        s2 <- mgu (apply s1 r) (apply s1 r')
+        return (s2 @@ s1)
+
+
+-- DEPR TTuple
+--mgu (TTuple args1) (TTuple args2)
+--   = do let lenArgs1 = length args1
+--        let lenArgs2 = length args2
+--        -- check the dimensions of the tuples are the same
+--        case lenArgs1 == lenArgs2 of
+--           True  -> foldM (\oldSub (t1,t2) -> case mgu (apply oldSub t1) (apply oldSub t2) of
+--                                                 Nothing      -> Nothing
+--                                                 Just newSub  -> return (newSub @@ oldSub)) 
+--                          nullSubst
+--                          (zip args1 args2)
+--           False -> Nothing 
+
+mgu (TVar u) t        = varBind u t
+mgu t (TVar u)        = varBind u t
+mgu (TCon tc1) (TCon tc2)
+           | tc1==tc2 = return nullSubst
+           | otherwise = fail "mgu: Constructors don't match"
+--mgu (TGen n tv) (TGen n' tv') | n == n' = varBind tv' (TVar tv)
+mgu t1 t2  = fail "mgu: types do not unify"
+
+varBind u t | t == TVar u      = return nullSubst
+            | u `elem` tv t    = fail "varBind: occurs check fails"
+            | kind u == kind t = return (u +-> t)
+            | otherwise        = fail "varBind: kinds do not match"
+
+match :: Monad m => Type -> Type -> m Subst
+
+match (TAp l r) (TAp l' r') 
+   = do sl <- match l l'
+        sr <- match r r'
+        merge sl sr
+
+match (TArrow l r) (TArrow l' r') 
+   = do sl <- match l l'
+        sr <- match r r'
+        merge sl sr
+
+
+-- DEPR TTuple
+--match (TTuple args1) (TTuple args2) 
+--   = do let lenArgs1 = length args1
+--        let lenArgs2 = length args2
+--        -- check the dimensions of the tuples are the same
+--        case lenArgs1 == lenArgs2 of
+--           True  -> foldM (\oldSub (t1,t2) -> case match t1 t2 of
+--                                                 Nothing      -> Nothing
+--                                                 Just newSub  -> merge oldSub newSub)
+--                          nullSubst
+--                          (zip args1 args2)
+--           False -> Nothing 
+
+match (TVar u) t
+   | kind u == kind t = return (u +-> t)
+
+match (TCon tc1) (TCon tc2)
+   | tc1==tc2         = return nullSubst
+
+match t1 t2           = fail $ "match: " ++ show (t1,t2)
+
+tTTuple ts | length ts < 2 = error "tTTuple"
+tTTuple ts = foldl TAp (toTuple (length ts)) ts
+-----------------------------------------------------------------------------
+
+instance Types Scheme where
+  apply s (Forall ks qt) = Forall ks (apply s qt)
+  tv (Forall ks qt)      = tv qt
+
+quantify      :: [Tyvar] -> Qual Type -> Scheme
+quantify vs qt = Forall ks (apply s qt)
+ where vs' = [ v | v <- tv qt, v `elem` vs ]
+       ks  = map kind vs'
+       s   = listToFM $ map (\(a@(Tyvar x _ _),b) -> (x,b a)) $ zip vs' (map TGen [0..])
+
+toScheme      :: Type -> Scheme
+toScheme t     = Forall [] ([] :=> t)
+
+unQuantify :: Scheme -> (Qual Type)
+unQuantify (Forall _ (ps :=> t)) =  map uq' ps :=> uq t where
+    uq (TAp a b) = TAp (uq a) (uq b)
+    uq (TArrow a b) = TArrow (uq a) (uq b)
+--    uq (TTuple ts) = TTuple (map uq ts)
+    uq (TGen _ tv) = TVar tv
+    uq x = x
+    uq' (IsIn s t) = IsIn s (uq t)
+
+-----------------------------------------------------------------------------
+
+assumpToPair :: Assump -> (HsName, Scheme)
+assumpToPair (n :>: s) = (n,s)
+
+pairToAssump :: (HsName, Scheme) -> Assump
+pairToAssump (n,s) = (n :>: s)
+
+instance Types Assump where
+  apply s (i :>: sc) = i :>: (apply s sc)
+  tv (i :>: sc)      = tv sc
+
+
+assumpId :: Assump -> HsName 
+assumpId (id :>: _scheme) = id
+
+assumpScheme :: Assump -> Scheme
+assumpScheme (_id :>: scheme) = scheme 
+
+makeAssump :: HsName -> Scheme -> Assump
+makeAssump name scheme = name :>: scheme
addfile ./FrontEnd/TypeSigs.hs
hunk ./FrontEnd/TypeSigs.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              The Hatchet Team (see file Contributors)
+
+        Module:                 TypeSigs
+
+        Description:            Collects all the type signatures from a module
+
+        Primary Authors:        Bernie Pope
+
+        Notes:                  See the file License for license information
+
+-------------------------------------------------------------------------------}
+
+module TypeSigs (collectSigs,
+                 SigEnv,
+                 listSigsToSigEnv) where
+
+--import FrontEnd.Env              (Env,
+--                         listToEnv)
+
+import Type             (assumpToPair)
+
+import KindInfer        (KindEnv)
+
+import Representation   (Scheme)
+
+import TypeUtils        (aHsTypeSigToAssumps)
+
+import HsSyn  
+import qualified Data.Map as Map
+
+--------------------------------------------------------------------------------
+
+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 ((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 (HsVar {}) = []
+
+collectSigsFromExp (HsCon {}) = []
+
+collectSigsFromExp (HsLit {}) = []
+
+collectSigsFromExp (HsInfixApp e1 e2 e3)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2 ++
+     collectSigsFromExp e3
+
+collectSigsFromExp (HsApp e1 e2)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2
+
+collectSigsFromExp (HsNegApp e)
+   = collectSigsFromExp e
+
+collectSigsFromExp (HsLambda _sloc _ e)
+   = collectSigsFromExp e
+
+collectSigsFromExp (HsLet decls e)
+   = collectSigsFromDecls decls ++
+     collectSigsFromExp e
+
+collectSigsFromExp (HsIf e1 e2 e3)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2 ++
+     collectSigsFromExp e3 
+
+collectSigsFromExp (HsCase e alts)
+   = collectSigsFromExp e ++
+     concatMap collectSigsFromAlt alts
+
+collectSigsFromExp (HsDo stmts)
+   = concatMap collectSigsFromStmt stmts
+
+collectSigsFromExp (HsTuple exps)
+   = concatMap collectSigsFromExp exps
+
+collectSigsFromExp (HsList exps)
+   = concatMap collectSigsFromExp exps
+
+collectSigsFromExp (HsParen e)
+   = collectSigsFromExp e
+
+collectSigsFromExp (HsLeftSection e1 e2)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2
+
+collectSigsFromExp (HsRightSection e1 e2)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2
+
+collectSigsFromExp (HsRecConstr _ fs) = concat [ collectSigsFromExp e | HsFieldUpdate _ e <- fs ]
+--   = error "collectSigsFromExp (HsRecConstr _ _) not implemented yet"
+
+collectSigsFromExp (HsRecUpdate e fs) =  concat $ collectSigsFromExp e:[ collectSigsFromExp e | HsFieldUpdate _ e <- fs ]
+--   = error "collectSigsFromExp (HsRecUpdate _ _) not implemented yet"
+
+collectSigsFromExp (HsEnumFrom e)
+   = collectSigsFromExp e
+
+collectSigsFromExp (HsEnumFromTo e1 e2)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2
+
+collectSigsFromExp (HsEnumFromThen e1 e2)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2
+
+collectSigsFromExp (HsEnumFromThenTo e1 e2 e3)
+   = collectSigsFromExp e1 ++
+     collectSigsFromExp e2 ++
+     collectSigsFromExp e3
+
+collectSigsFromExp (HsListComp e stmts)
+   = collectSigsFromExp e ++
+     concatMap collectSigsFromStmt stmts
+
+collectSigsFromExp (HsExpTypeSig _ e _)
+   = collectSigsFromExp e
+
+collectSigsFromExp (HsAsPat _ e)
+   = collectSigsFromExp e
+
+collectSigsFromExp (HsWildCard _) = []
+
+collectSigsFromExp (HsIrrPat e)
+   = collectSigsFromExp e
+
+collectSigsFromAlt :: (HsAlt) -> [(HsDecl)]
+
+collectSigsFromAlt (HsAlt _ _ (HsUnGuardedAlt e) decls)
+   = collectSigsFromExp e ++
+     collectSigsFromDecls decls
+
+collectSigsFromAlt (HsAlt _ _ (HsGuardedAlts alts) decls)
+   = concatMap collectSigsFromGuardedAlt alts ++
+     collectSigsFromDecls decls
+
+collectSigsFromGuardedAlt :: (HsGuardedAlt) -> [(HsDecl)]
+
+collectSigsFromGuardedAlt (HsGuardedAlt _ 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 HsName Scheme
+
+listSigsToSigEnv :: KindEnv -> [HsDecl] -> SigEnv
+listSigsToSigEnv kt sigs
+   = Map.fromList $ 
+        map assumpToPair $
+        concatMap (aHsTypeSigToAssumps kt) sigs
+        
+
addfile ./FrontEnd/TypeSynonyms.hs
hunk ./FrontEnd/TypeSynonyms.hs 1
+
+module TypeSynonyms (
+    removeSynonymsFromType,
+    declsToTypeSynonyms,
+    TypeSynonyms
+    ) where
+
+import HsSyn  
+import HsErrors
+import Control.Monad.Writer
+import Control.Monad.Identity
+import List
+import GenUtil
+import Doc.DocLike
+import Warning
+import qualified Data.Map as Map
+import Data.Monoid
+import Name
+import Binary
+import HasSize
+
+
+newtype TypeSynonyms = TypeSynonyms (Map.Map Name ([HsName], HsType, SrcLoc))
+    deriving(Monoid,Binary,HasSize) 
+
+-- | 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 (HsUnQualType t) , sl)) | (HsTypeDecl sl name args t) <- ts]
+ 
+removeSynonymsFromType :: TypeSynonyms -> HsType -> HsType
+removeSynonymsFromType syns t
+   = runIdentity $ 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 x = mapHsTypeHsType (\x -> fv x >> return x) x >> return ()
+
+
+evalTypeSyms :: MonadWarn m => TypeSynonyms -> HsType -> m HsType
+evalTypeSyms (TypeSynonyms tmap) t = 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
+            warn sl "partialap" ("Partially applied typesym:" <+> show n <+> "need" <+> show (- excess) <+> "more arguments.")
+            unwind x stack
+          else do 
+            eval (drop (length args) stack) (subst (Map.fromList [(a,s) | a <- args | s <- stack]) t)  
+    eval stack (HsTyApp t1 t2) = eval (t2:stack) t1 
+    eval stack x = do
+        t <- mapHsTypeHsType (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) = HsTyForall vs  t { hsQualTypeType =  subst (foldr ($) sm (map (\v m -> Map.delete (hsTyVarBindName v) m) vs)) (hsQualTypeType t) } 
+    subst sm (HsTyVar n) | Just v <- Map.lookup n sm = v
+    subst sm t = runIdentity $ mapHsTypeHsType (return . subst sm) t
+
+
addfile ./FrontEnd/TypeSyns.hs
hunk ./FrontEnd/TypeSyns.hs 1
+module TypeSyns( expandTypeSyns ) where 
+
+import HsSyn hiding(srcLoc)
+import Data.FiniteMap
+import List             (nub)
+import Char        
+import Utils     
+import Control.Monad.State
+import GenUtil
+import Data.Monoid
+import MonadUtil
+import MonoidUtil
+import Warning
+import TypeSynonyms
+import List
+import Control.Monad.Fix
+import FrontEnd.Env
+import FrontEnd.Desugar (doToExp)
+import DDataUtil
+import qualified Seq
+import Control.Monad.Writer
+import Warning
+
+
+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})
+
+
+
+getCurrentModule :: ScopeSM Module
+getCurrentModule = gets currentModule
+
+
+setSrcLoc e = modify (\s -> s { srcLoc = e `mappend` srcLoc s}) 
+
+
+expandTypeSyns :: MonadWarn m => TypeSynonyms -> HsModule -> m HsModule
+expandTypeSyns syns m = return rm where
+    startState = ScopeState { 
+        errors         = [],
+        synonyms       =  syns,
+        srcLoc         = bogusASrcLoc,
+        currentModule  = hsModuleName m
+        }
+
+    (rm, _) = runState (renameDecls m) startState 
+
+
+-- 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 = do
+    setSrcLoc srcLoc
+    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 c n t) subTable = do
+    setSrcLoc a
+    n <- renameHsName n subTable
+    t <- renameHsQualType t subTable
+    return  (HsForeignDecl a b c n t)
+
+renameHsDecl (HsFunBind hsMatches) subTable = do
+    hsMatches' <- renameHsMatches hsMatches subTable
+    return (HsFunBind hsMatches')
+
+renameHsDecl (HsTypeSig srcLoc hsNames hsQualType) subTable = do
+    setSrcLoc srcLoc
+    hsNames' <- renameHsNames hsNames subTable
+    hsQualType' <- renameHsQualType hsQualType subTable
+    return (HsTypeSig srcLoc hsNames' hsQualType')
+
+renameHsDecl (HsDataDecl srcLoc hsContext hsName hsNames1 hsConDecls hsNames2) 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 (HsDataDecl srcLoc hsContext' hsName' hsNames1' hsConDecls' hsNames2)
+renameHsDecl (HsTypeDecl srcLoc name hsNames t) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameTypeHsName name subTable
+    t' <- renameHsType' False t undefined
+    return (HsTypeDecl srcLoc  hsName' hsNames t')
+
+renameHsDecl (HsNewTypeDecl srcLoc hsContext hsName hsNames1 hsConDecl hsNames2) subTable = do
+    setSrcLoc srcLoc
+    hsContext' <- renameHsContext hsContext subTable
+    hsNames1' <- renameHsNames hsNames1 subTable
+    hsConDecl' <- renameHsConDecl hsConDecl subTable
+    return (HsNewTypeDecl srcLoc hsContext' hsName hsNames1' hsConDecl' hsNames2)
+
+renameHsDecl (HsClassDecl srcLoc hsQualType hsDecls) subTable = do
+    setSrcLoc srcLoc
+    hsQualType' <- renameHsQualType hsQualType undefined
+    hsDecls' <- renameHsDecls hsDecls subTable
+    return (HsClassDecl srcLoc hsQualType' hsDecls')
+renameHsDecl (HsInstDecl srcLoc hsQualType hsDecls) subTable = do
+    setSrcLoc srcLoc
+    hsQualType' <- renameHsQualType hsQualType subTable
+    hsDecls' <- renameHsDecls hsDecls subTable
+    return (HsInstDecl srcLoc hsQualType' hsDecls')
+renameHsDecl (HsInfixDecl srcLoc assoc int hsNames) subTable = do
+    setSrcLoc srcLoc
+    hsNames' <- renameHsNames hsNames subTable
+    return $ HsInfixDecl srcLoc assoc int hsNames'
+
+renameHsDecl otherHsDecl _ = return otherHsDecl
+
+
+
+
+renameHsQualType :: HsQualType -> SubTable -> ScopeSM (HsQualType)
+renameHsQualType (HsQualType hsContext hsType) subTable = do
+      hsContext' <- renameHsContext hsContext subTable
+      hsType' <- renameHsType hsType subTable
+      return (HsQualType hsContext' hsType')
+renameHsQualType (HsUnQualType hsType) subTable = do
+      hsType' <- renameHsType hsType subTable
+      return (HsQualType [] hsType')
+
+renameHsContext :: HsContext -> SubTable -> ScopeSM (HsContext)
+renameHsContext = mapRename renameHsAsst
+
+renameHsAsst :: HsAsst -> SubTable -> ScopeSM (HsAsst)
+renameHsAsst (hsName1, hsName2) subTable = do
+      hsName1' <- renameTypeHsName hsName1 subTable  -- for class names
+      hsName2' <- renameTypeHsName hsName2 subTable
+      return (hsName1', hsName2')
+
+renameHsConDecls :: [HsConDecl] -> SubTable -> ScopeSM ([HsConDecl])
+renameHsConDecls = mapRename renameHsConDecl
+
+renameHsConDecl :: HsConDecl -> SubTable -> ScopeSM (HsConDecl)
+renameHsConDecl (HsConDecl srcLoc hsName hsBangTypes) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameHsName hsName subTable
+    hsBangTypes' <- renameHsBangTypes hsBangTypes subTable
+    return (HsConDecl srcLoc hsName' hsBangTypes') 
+renameHsConDecl (HsRecDecl srcLoc hsName stuff) subTable = do
+    setSrcLoc srcLoc
+    hsName' <- renameHsName hsName subTable
+    stuff' <- sequence [ do ns' <- mapRename renameHsName ns subTable; t' <- renameHsBangType t subTable; return (ns',t')  |  (ns,t) <- stuff]
+    return (HsRecDecl srcLoc hsName' 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 (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
+        False <- return dovar
+        v <- renameHsQualType v subTable
+        return $ HsTyForall ts v
+    pp t | not dovar = t
+    pp t = do
+        t' <- t
+        syns <- gets synonyms
+        --addDiag $ show ("pp", t')
+        --return t'
+        return (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 = do
+    setSrcLoc srcLoc
+    hsName' <- renameHsName hsName subTable
+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc FunPat
+    hsPats' <- renameHsPats hsPats subTable'
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls WhereFun
+    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 (HsPVar hsName) subTable = do
+      hsName' <- renameHsName hsName subTable
+      return (HsPVar hsName')
+renameHsPat (HsPLit hsLiteral) _subTable
+  = return (HsPLit hsLiteral)
+renameHsPat (HsPNeg hsPat) subTable = do
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPNeg hsPat')
+renameHsPat (HsPInfixApp hsPat1 hsName hsPat2) subTable = do
+      hsPat1' <- renameHsPat hsPat1 subTable
+      hsPat2' <- renameHsPat hsPat2 subTable
+      hsName' <- renameHsName hsName subTable
+      return (HsPInfixApp hsPat1' hsName' hsPat2')
+renameHsPat (HsPApp hsName hsPats) subTable = do
+      hsPats' <- renameHsPats hsPats subTable
+      hsName' <- renameHsName hsName subTable
+      return (HsPApp hsName' hsPats')  -- NOTE: Bryn changed this so we also rename hsName and not just the hsPats
+renameHsPat (HsPTuple hsPats) subTable = do
+      hsPats' <- renameHsPats hsPats subTable
+      return (HsPTuple hsPats')
+renameHsPat (HsPList hsPats) subTable = do
+      hsPats' <- renameHsPats hsPats subTable
+      return (HsPList hsPats')
+renameHsPat (HsPParen hsPat) subTable = do
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPParen hsPat')
+renameHsPat (HsPRec hsName hsPatFields) subTable = do
+      -- the hsName can be ignored as it is a Constructor
+      hsPatFields' <- renameHsPatFields hsPatFields subTable
+      return (HsPRec hsName hsPatFields)
+renameHsPat (HsPAsPat hsName hsPat) subTable = do
+      hsName' <- renameHsName hsName subTable
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPAsPat hsName' hsPat')
+renameHsPat HsPWildCard subTable = do
+      return HsPWildCard
+--renameHsPat (HsPWildCard) _subTable
+--  = return HsPWildCard
+renameHsPat (HsPIrrPat hsPat) subTable = do
+      hsPat' <- renameHsPat hsPat subTable
+      return (HsPIrrPat hsPat')
+
+
+renameHsPatFields :: [HsPatField] -> SubTable -> ScopeSM ([HsPatField])
+renameHsPatFields = mapRename renameHsPatField
+
+-- although the hsNames here must be unique (field names),
+-- I rename them for the sake of completeness
+renameHsPatField :: HsPatField -> SubTable -> ScopeSM (HsPatField)
+{-
+renameHsPatField (HsPFieldPun hsName) subTable
+  = do
+      hsName' <- renameHsName hsName subTable
+      return (HsPFieldPun hsName')
+-}
+renameHsPatField (HsPFieldPat hsName hsPat) subTable = do
+    hsName' <- renameHsName hsName undefined
+    hsPat' <- renameHsPat hsPat subTable
+    return (HsPFieldPat hsName' hsPat')
+
+
+renameHsRhs :: HsRhs -> SubTable -> ScopeSM HsRhs
+renameHsRhs (HsUnGuardedRhs hsExp) subTable = do
+      hsExp' <- renameHsExp hsExp subTable
+      return (HsUnGuardedRhs hsExp')
+renameHsRhs (HsGuardedRhss hsGuardedRhss) subTable = do
+      hsGuardedRhss' <- renameHsGuardedRhss hsGuardedRhss subTable
+      return (HsGuardedRhss hsGuardedRhss')
+
+
+renameHsGuardedRhss :: [HsGuardedRhs] -> SubTable -> ScopeSM ([HsGuardedRhs])
+renameHsGuardedRhss = mapRename renameHsGuardedRhs
+
+renameHsGuardedRhs :: HsGuardedRhs -> SubTable -> ScopeSM HsGuardedRhs
+renameHsGuardedRhs (HsGuardedRhs srcLoc hsExp1 hsExp2) subTable = do
+    setSrcLoc srcLoc
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsGuardedRhs srcLoc hsExp1' hsExp2')
+
+
+renameHsExps :: [HsExp] -> SubTable -> ScopeSM ([HsExp])
+renameHsExps = mapRename renameHsExp
+
+renameHsExp :: HsExp -> SubTable -> ScopeSM HsExp
+renameHsExp (HsAsPat n e) s = renameHsExp e s >>= \e -> return (HsAsPat n e)
+renameHsExp (HsVar hsName) subTable = do
+    hsName' <- renameHsName hsName subTable
+    return (HsVar hsName' )
+renameHsExp (HsCon hsName) subTable = do
+    hsName' <- renameHsName hsName subTable
+    return (HsCon hsName') 
+renameHsExp i@(HsLit _) _ = do
+    return $ i
+renameHsExp (HsInfixApp hsExp1 hsExp2 hsExp3) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    hsExp3' <- renameHsExp hsExp3 subTable
+    return (HsInfixApp hsExp1' hsExp2' hsExp3')
+renameHsExp (HsApp hsExp1 hsExp2) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsApp hsExp1' hsExp2')
+renameHsExp (HsNegApp hsExp) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsNegApp hsExp')
+renameHsExp (HsLambda srcLoc hsPats hsExp) subTable = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsPats subTable hsPats srcLoc LamPat
+    hsPats' <- renameHsPats hsPats subTable'
+    hsExp' <- renameHsExp hsExp subTable'
+    return (HsLambda srcLoc hsPats' hsExp')
+renameHsExp (HsLet hsDecls hsExp) subTable = do
+    subTable' <- updateSubTableWithHsDecls subTable hsDecls LetFun
+    hsDecls' <- renameHsDecls hsDecls subTable'
+    hsExp' <- renameHsExp hsExp subTable'
+    return (HsLet hsDecls' hsExp')
+renameHsExp (HsIf hsExp1 hsExp2 hsExp3) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    hsExp3' <- renameHsExp hsExp3 subTable
+    return (HsIf hsExp1' hsExp2' hsExp3')
+renameHsExp (HsCase hsExp hsAlts) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    hsAlts' <- renameHsAlts hsAlts subTable
+    return (HsCase hsExp' hsAlts')
+renameHsExp (HsDo hsStmts) subTable = do
+    let e = doToExp hsStmts
+    renameHsExp e subTable
+    --(hsStmts',_) <- renameHsStmts hsStmts subTable
+    --return (doToExp hsStmts')
+renameHsExp (HsTuple hsExps) subTable = do
+    hsExps' <- renameHsExps hsExps subTable
+    return (HsTuple hsExps')
+renameHsExp (HsList hsExps) subTable = do
+    hsExps' <- renameHsExps hsExps subTable
+    return (HsList hsExps')
+renameHsExp (HsParen hsExp) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsParen hsExp')
+renameHsExp (HsLeftSection hsExp1 hsExp2) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsLeftSection hsExp1' hsExp2')
+renameHsExp (HsRightSection hsExp1 hsExp2) subTable = do
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsRightSection hsExp1' hsExp2')
+-- XXX I'm not 100% sure that this bit works.
+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 (HsEnumFrom hsExp) subTable = do
+    let x = desugarEnum "enumFrom" [hsExp]
+    hsExp' <- renameHsExp x subTable
+    --return (HsEnumFrom hsExp')
+    return ( hsExp')
+renameHsExp (HsEnumFromTo hsExp1 hsExp2) subTable = do
+    let x = desugarEnum "enumFromTo" [hsExp1, hsExp2]
+    hsExp' <- renameHsExp x subTable
+    return ( hsExp')
+    --hsExp' <- renameHsExp x subTable
+    --hsExp1' <- renameHsExp hsExp1 subTable
+    --hsExp2' <- renameHsExp hsExp2 subTable
+    --return (HsEnumFromTo hsExp1' hsExp2')
+renameHsExp (HsEnumFromThen hsExp1 hsExp2) subTable = do
+    let x = desugarEnum "enumFromThen" [hsExp1, hsExp2]
+    hsExp' <- renameHsExp x subTable
+    return ( hsExp')
+    --hsExp1' <- renameHsExp hsExp1 subTable
+    --hsExp2' <- renameHsExp hsExp2 subTable
+    --return (HsEnumFromThen hsExp1' hsExp2')
+renameHsExp (HsEnumFromThenTo hsExp1 hsExp2 hsExp3) subTable = do
+    let x = desugarEnum "enumFromThenTo" [hsExp1, hsExp2, hsExp3]
+    hsExp' <- renameHsExp x subTable
+    return ( hsExp')
+    --hsExp1' <- renameHsExp hsExp1 subTable
+    --hsExp2' <- renameHsExp hsExp2 subTable
+    --hsExp3' <- renameHsExp hsExp3 subTable
+    --return (HsEnumFromThenTo hsExp1' hsExp2' hsExp3')
+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 (HsAsPat hsName hsExp) subTable = do
+    hsName' <- renameHsName hsName subTable
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsAsPat hsName' hsExp')
+renameHsExp (HsWildCard x) _ = do return (HsWildCard x)
+renameHsExp (HsIrrPat hsExp) subTable = do
+    hsExp' <- renameHsExp hsExp subTable
+    return (HsIrrPat hsExp')
+
+desugarEnum s as = foldl HsApp (HsVar (UnQual $ HsIdent s)) as
+
+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 = do
+    setSrcLoc srcLoc
+    subTable' <- updateSubTableWithHsPats subTable [hsPat] srcLoc CasePat
+    hsPat' <- renameHsPat hsPat subTable'
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls WhereFun
+    hsDecls' <- renameHsDecls hsDecls subTable''
+    hsGuardedAlts' <- renameHsGuardedAlts hsGuardedAlts subTable''
+    return (HsAlt srcLoc hsPat' hsGuardedAlts' hsDecls')
+
+renameHsGuardedAlts :: HsGuardedAlts -> SubTable -> ScopeSM (HsGuardedAlts)
+renameHsGuardedAlts (HsUnGuardedAlt hsExp) subTable = do
+      hsExp' <- renameHsExp hsExp subTable
+      return (HsUnGuardedAlt hsExp')
+renameHsGuardedAlts (HsGuardedAlts hsGuardedAltList) subTable = do
+      hsGuardedAltList' <- renameHsGuardedAltList hsGuardedAltList subTable
+      return (HsGuardedAlts hsGuardedAltList')
+
+renameHsGuardedAltList :: [HsGuardedAlt] -> SubTable -> ScopeSM [HsGuardedAlt]
+renameHsGuardedAltList = mapRename renameHsGuardedAlt
+
+renameHsGuardedAlt :: HsGuardedAlt -> SubTable -> ScopeSM HsGuardedAlt
+renameHsGuardedAlt (HsGuardedAlt srcLoc hsExp1 hsExp2) subTable = do
+    setSrcLoc srcLoc
+    hsExp1' <- renameHsExp hsExp1 subTable
+    hsExp2' <- renameHsExp hsExp2 subTable
+    return (HsGuardedAlt 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 -> Binding -> ScopeSM (SubTable)
+clobberHsNamesAndUpdateIdentTable ((hsName,srcLoc):hsNamesAndASrcLocs) subTable binding = do
+      subTable'  <- clobberHsName hsName subTable
+      subTable'' <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable' binding
+      return (subTable'')
+clobberHsNamesAndUpdateIdentTable [] subTable _binding = 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
+
+
+
+renameAndQualify :: HsName -> Int -> Module -> HsName
+renameAndQualify name unique currentMod
+    = case rename name unique of
+           UnQual name' -> Qual currentMod name'
+           qual_name    -> qual_name
+
+-- renames a haskell name with its unique number 
+rename :: HsName -> Int -> HsName
+rename n unique = hsNameIdent_u (hsIdentString_u ((show unique ++ "_") ++)) n
+
+-- unRename gets the original identifier name 
+
+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 $ fromHsIdentifier 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
+
+
+updateSubTableWithHsDecls :: SubTable -> [HsDecl] -> Binding -> ScopeSM (SubTable)
+updateSubTableWithHsDecls subTable [] _binding = return subTable
+updateSubTableWithHsDecls subTable (hsDecl:hsDecls) binding = do
+    let hsNamesAndASrcLocs = getHsNamesAndASrcLocsFromHsDecl hsDecl
+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable binding
+    subTable'' <- updateSubTableWithHsDecls subTable' hsDecls binding
+    return (subTable'')
+
+updateSubTableWithHsPats :: SubTable -> [HsPat] -> SrcLoc -> Binding -> ScopeSM (SubTable)
+updateSubTableWithHsPats subTable (hsPat:hsPats) srcLoc binding = do
+    let hsNamesAndASrcLocs = zip (getHsNamesFromHsPat hsPat) (repeat srcLoc)
+    subTable'  <- clobberHsNamesAndUpdateIdentTable hsNamesAndASrcLocs subTable binding
+    subTable'' <- updateSubTableWithHsPats subTable' hsPats srcLoc binding
+    return subTable''
+updateSubTableWithHsPats subTable [] _srcLoc _binding = 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 GenPat
+    return (subTable')
+
+----------------------------------------------------------
+-- the following updateSubTableWith* functions do not need to alter the identTable aswell
+--
+
+
+-- takes a list of HsNames representing type variables in a data decl and
+-- adds them to the current subTable
+
+updateSubTableWithHsNames :: SubTable -> [HsName] -> ScopeSM (SubTable)
+updateSubTableWithHsNames subTable hsNames = do
+      subTable' <- clobberHsNames hsNames subTable
+      return (subTable')
+
+-- 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')
+
+
+
+-- takes a list of decls and examines only the class decls
+-- to get the names of variables used in their type sigs
+
+updateSubTableWithClasses :: SubTable -> [HsDecl] -> ScopeSM (SubTable)
+updateSubTableWithClasses subTable []
+  = return subTable
+updateSubTableWithClasses subTable (hsDecl:hsDecls)
+  = do
+      let hsNames = getHsNamesFromClass hsDecl
+      subTable'  <- clobberHsNames hsNames subTable
+      subTable'' <- updateSubTableWithClasses subTable' hsDecls 
+      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)]
+
+
+collectDefsHsModule :: HsModule -> [(Bool,HsName,SrcLoc,[HsName])]
+collectDefsHsModule m = map g $ snd $ runWriter (mapM_ f (hsModuleDecls m)) where
+    g (b,n,sl,ns) = (b,mod n, sl, map mod ns) 
+    mod = qualifyName (hsModuleName m)
+    f (HsForeignDecl a _ _ n _)  = tell [(False,n,a,[])]
+    f (HsFunBind [])  = return ()
+    f (HsFunBind (HsMatch a n _ _ _:_))  = tell [(False,n,a,[])]
+    f (HsPatBind srcLoc p _ _) = tell [ (False,n,srcLoc,[]) | n <- (getHsNamesFromHsPat p) ]
+    f (HsTypeDecl sl n _ _) = tell [(True,n,sl,[])]
+    f (HsDataDecl sl _ n _ cs _) = tell $ (True,n,sl,fsts cs'):[ (False,n,sl,[]) | (n,sl) <- cs'] where 
+        cs' = concatMap namesHsConDecl cs
+    f (HsNewTypeDecl sl _ n _ c _) =  tell $ (True,n,sl,fsts cs'):[ (False,n,sl,[]) | (n,sl) <- cs'] where 
+        cs' = namesHsConDecl c
+    f cd@(HsClassDecl sl _ ds) = tell $ (True,z,sl,fsts cs):[ (False,n,a,[]) | (n,a) <- cs]  where
+        Just z = maybeGetDeclName cd    
+        cs = fst (mconcatMap namesHsDeclTS ds)
+    f _ = return ()
+
+namesHsModule m = mconcatMap namesHsDecl (hsModuleDecls m)
+
+namesHsDecl :: HsDecl -> ([(HsName, SrcLoc)],[(HsName, SrcLoc)])
+namesHsDecl (HsForeignDecl a _ _ n _)  = ([(n,a)],[])
+namesHsDecl (HsFunBind hsMatches)  = (getHsNamesAndASrcLocsFromHsMatches hsMatches, [])
+namesHsDecl (HsPatBind srcLoc p _ _) = (map (rtup srcLoc) (getHsNamesFromHsPat p),[])
+namesHsDecl (HsTypeDecl sl n _ _) = ([],[(n,sl)])
+namesHsDecl (HsDataDecl sl _ n _ cs _) = ( (concatMap namesHsConDecl cs) ,[(n,sl)])
+namesHsDecl (HsNewTypeDecl sl _ n _ c _) = ( (namesHsConDecl c),[(n,sl)])
+namesHsDecl cd@(HsClassDecl sl _ ds) = (mconcatMap namesHsDeclTS ds) `mappend` ([],[(z,sl)]) where
+    Just z = maybeGetDeclName cd
+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 
+    _ -> []
+
+getHsNamesFromHsPat :: HsPat -> [HsName]
+getHsNamesFromHsPat (HsPVar hsName) = [hsName]
+getHsNamesFromHsPat (HsPLit _hsName) = []
+getHsNamesFromHsPat (HsPNeg hsPat) = getHsNamesFromHsPat hsPat
+-- _hsName can be ignored as it is a Constructor (e.g. in (x:xs) we only want to know what's in scope; that is x and xs)
+getHsNamesFromHsPat (HsPInfixApp hsPat1 _hsName hsPat2) = getHsNamesFromHsPat hsPat1 ++ getHsNamesFromHsPat hsPat2
+getHsNamesFromHsPat (HsPApp _hsName hsPats) = concat (map getHsNamesFromHsPat hsPats)
+getHsNamesFromHsPat (HsPTuple hsPats) = concat (map getHsNamesFromHsPat hsPats)
+getHsNamesFromHsPat (HsPList hsPats) = concat (map getHsNamesFromHsPat hsPats)
+getHsNamesFromHsPat (HsPParen hsPat) = getHsNamesFromHsPat hsPat
+getHsNamesFromHsPat (HsPRec _hsName hsPatFields) = concat $ map getHsNamesFromHsPatField hsPatFields -- hsName can be ignored as it is a Constructor
+getHsNamesFromHsPat (HsPAsPat hsName hsPat) = hsName:(getHsNamesFromHsPat hsPat)
+getHsNamesFromHsPat (HsPWildCard) = []
+getHsNamesFromHsPat (HsPIrrPat hsPat) = getHsNamesFromHsPat hsPat
+
+-- the hsName can be ignored as it is the field name and must already be in scope
+getHsNamesFromHsPatField :: HsPatField -> [HsName]
+{-
+getHsNamesFromHsPatField (HsPFieldPun _hsName)
+  = []
+  -}
+getHsNamesFromHsPatField (HsPFieldPat _hsName hsPat)
+  = getHsNamesFromHsPat hsPat
+
+getHsNamesAndASrcLocsFromHsStmt :: HsStmt -> [(HsName, SrcLoc)]
+getHsNamesAndASrcLocsFromHsStmt (HsGenerator srcLoc hsPat _hsExp)
+  = zip (getHsNamesFromHsPat 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.
+
+getNewHsNamesFromHsQualType :: SubTable -> HsQualType -> [HsName]
+getNewHsNamesFromHsQualType subTable (HsQualType _hsContext hsType)
+  = getNewHsNamesFromHsType subTable hsType
+getNewHsNamesFromHsQualType subTable (HsUnQualType hsType)
+  = getNewHsNamesFromHsType subTable hsType
+
+getNewHsNamesFromHsType :: SubTable -> HsType -> [HsName]
+getNewHsNamesFromHsType subTable (HsTyFun hsType1 hsType2)
+  = (getNewHsNamesFromHsType subTable hsType1) ++ (getNewHsNamesFromHsType subTable hsType2)
+getNewHsNamesFromHsType subTable (HsTyTuple hsTypes)
+  = concat $ map (getNewHsNamesFromHsType subTable) hsTypes
+getNewHsNamesFromHsType subTable (HsTyApp hsType1 hsType2)
+  = (getNewHsNamesFromHsType subTable hsType1) ++ (getNewHsNamesFromHsType subTable hsType2)
+getNewHsNamesFromHsType subTable (HsTyVar hsName) = [hsName]
+getNewHsNamesFromHsType _subTable (HsTyCon _hsName)
+  = [] -- don't rename the Constructors
+
+getHsNamesFromHsQualType :: HsQualType -> [HsName]
+getHsNamesFromHsQualType (HsQualType _hsContext hsType)
+  = getHsNamesFromHsType hsType
+getHsNamesFromHsQualType (HsUnQualType hsType)
+  = getHsNamesFromHsType hsType
+
+getHsNamesFromHsType :: HsType -> [HsName]
+getHsNamesFromHsType (HsTyFun hsType1 hsType2)
+  = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)
+getHsNamesFromHsType (HsTyTuple hsTypes)
+  = concat $ map getHsNamesFromHsType hsTypes
+getHsNamesFromHsType (HsTyApp hsType1 hsType2)
+  = (getHsNamesFromHsType hsType1) ++ (getHsNamesFromHsType hsType2)
+getHsNamesFromHsType (HsTyVar hsName)
+  = [hsName]
+getHsNamesFromHsType (HsTyCon _hsName)
+  = [] -- don't rename the Constructors
+
+
+-- gets the names of the functions declared in a class declaration
+
+getHsNamesFromClass :: HsDecl -> [HsName]
+getHsNamesFromClass (HsClassDecl _srcLoc _hsQualType hsDecls)
+  = getHsNamesFromTypeSigs hsDecls
+getHsNamesFromClass _otherDecl
+  = []
+
+-- gets the names of the functions whose types are declared in class decls
+
+getHsNamesFromTypeSigs :: [HsDecl] -> [HsName]
+getHsNamesFromTypeSigs ((HsTypeSig _srcLoc hsNames _hsQualType):hsDecls)
+  = hsNames ++ getHsNamesFromTypeSigs hsDecls
+getHsNamesFromTypeSigs (_otherDecl:hsDecls)
+  = getHsNamesFromTypeSigs hsDecls
+getHsNamesFromTypeSigs []
+  = []
+
+--------------------------------------------------------------------------------
+
+-- the Renameable class
+
+
+-- stores the instance Renameable for all of HsSyn
+
+class Renameable a where
+    replaceName :: (HsName -> HsName) -> a -> a
+
+instance Renameable SrcLoc where
+    replaceName f = id
+
+instance Renameable HsExportSpec where
+    replaceName f hsexportspec
+      = let a # b = a $ (replaceName f b)
+        in case hsexportspec of
+            HsEVar  name               ->
+                HsEVar  # name			
+            HsEAbs  name               ->
+                HsEAbs  # name			
+            HsEThingAll  name		 ->
+                HsEThingAll  # name		
+            HsEThingWith  name names	 ->
+                HsEThingWith  # name # names	
+            HsEModuleContents mod	 ->
+                HsEModuleContents mod	
+
+
+instance Renameable HsImportDecl where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+            a $$ b = a b
+            infixl 0 $$
+        in case object of
+            HsImportDecl  srcloc mod bool maybe1 maybe2 ->
+                HsImportDecl # srcloc $$ mod $$ bool $$ maybe1 $$ maybe2'
+                where maybe2' = fmap (\(b,importSpec) -> (b, replaceName f importSpec)) maybe2
+
+
+instance Renameable HsImportSpec where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsIVar  name			 ->
+                HsIVar  # name			
+            HsIAbs  name			 ->
+                HsIAbs  # name			
+            HsIThingAll  name		 ->
+                HsIThingAll  # name		
+            HsIThingWith  name names	 ->
+                HsIThingWith  # name # names	
+
+
+{-
+instance Renameable HsInfixDecl where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsInfixDecl  srcloc fixity names ->
+                HsInfixDecl  # srcloc # fixity # names
+-}
+
+
+{-
+instance Renameable HsFixity where
+    replaceName f = id
+-}
+
+instance Renameable HsAssoc where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsAssocNone  ->
+                HsAssocNone 
+            HsAssocLeft  ->
+                HsAssocLeft 
+            HsAssocRight  ->
+                HsAssocRight 
+
+
+instance Renameable (HsDecl) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsTypeDecl 	srcloc name names typ ->
+                HsTypeDecl 	srcloc # name # names # typ
+            HsDataDecl 	srcloc context name names condecls names' ->
+                HsDataDecl 	srcloc # context # name # names # condecls # names'
+            HsNewTypeDecl 	srcloc context name names condecl names' ->
+                HsNewTypeDecl 	srcloc # context # name # names # condecl # names'
+            HsClassDecl 	srcloc qualtyp objects ->
+                HsClassDecl 	srcloc # qualtyp # objects
+            HsInstDecl 	srcloc qualtyp objects ->
+                HsInstDecl 	srcloc # qualtyp # objects
+            HsDefaultDecl 	srcloc typ ->
+                HsDefaultDecl 	srcloc # typ
+            HsTypeSig 	srcloc names qualtyp ->
+                HsTypeSig 	srcloc # names # qualtyp
+            -- HsFunBind       srcloc matc ->
+            HsFunBind          matc ->
+                -- HsFunBind  # srcloc # matc
+                HsFunBind  # matc
+            HsPatBind 	srcloc pat r {-where-} objects ->
+                HsPatBind 	srcloc # pat # r # objects
+            od -> od
+
+
+instance Renameable (HsMatch) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsMatch  srcloc name pats r {-where-} objects ->
+                HsMatch  # srcloc # name # pats # r # objects
+
+
+instance Renameable HsConDecl where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsConDecl  srcloc name bangtyps ->
+                HsConDecl  # srcloc # name # bangtyps
+            HsRecDecl  srcloc name names_and_bangtyp ->
+                HsRecDecl  # srcloc # name # names_and_bangtyp
+
+
+
+
+instance Renameable HsBangType where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsBangedTy    typ ->
+                HsBangedTy  # typ
+            HsUnBangedTy  typ ->
+                HsUnBangedTy  # typ
+
+
+instance Renameable (HsRhs) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsUnGuardedRhs  exp ->
+                HsUnGuardedRhs  # exp
+            HsGuardedRhss   guardedrs ->
+                HsGuardedRhss  # guardedrs
+
+
+instance Renameable (HsGuardedRhs) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsGuardedRhs  srcloc exp exp' ->
+                HsGuardedRhs  # srcloc # exp # exp'
+
+
+instance Renameable HsQualType where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsQualType    context typ ->
+                HsQualType  # context # typ
+            HsUnQualType  typ ->
+                HsUnQualType  # typ
+
+
+instance Renameable HsType where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsTyFun    typ typ' ->
+                HsTyFun  # typ # typ'
+            HsTyTuple  typs ->
+                HsTyTuple  # typs
+            HsTyApp    typ typ' ->
+                HsTyApp  # typ # typ'
+            HsTyVar    name ->
+                HsTyVar  # name
+            HsTyCon    name ->
+                HsTyCon  # name
+
+instance Renameable HsLiteral where
+    replaceName f = id
+
+instance Renameable (HsExp) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            -- HsVar  name ann -> HsVar (replaceName f name) ann
+            HsVar  name -> HsVar (replaceName f name) 
+            HsCon  name ->
+                HsCon  # name 
+            HsLit  literal ->
+                HsLit  # literal
+            HsInfixApp  exp exp' exp'' ->
+                HsInfixApp  # exp # exp' # exp''
+            HsApp  exp exp' ->
+                HsApp  # exp # exp'
+            HsNegApp  exp ->
+                HsNegApp  # exp
+            HsLambda  srcloc pats exp ->
+                HsLambda  # srcloc # pats # exp
+            HsLet  objects exp ->
+                HsLet  # objects # exp
+            HsIf  exp exp' exp'' ->
+                HsIf  # exp # exp' # exp''
+            HsCase  exp alts ->
+                HsCase  # exp # alts
+            HsDo  stmts ->
+                HsDo  # stmts
+            HsTuple  exps ->
+                HsTuple  # exps
+            HsList  exps ->
+                HsList  # exps
+            HsParen  exp ->
+                HsParen  # exp
+            HsLeftSection  exp exp' ->
+                HsLeftSection  # exp # exp'
+            HsRightSection  exp exp' ->
+                HsRightSection  # exp # exp'
+            HsRecConstr  name fieldupdates ->
+                HsRecConstr  # name # fieldupdates
+            HsRecUpdate  exp fieldupdates ->
+                HsRecUpdate  # exp # fieldupdates
+            HsEnumFrom  exp ->
+                HsEnumFrom  # exp
+            HsEnumFromTo  exp exp' ->
+                HsEnumFromTo  # exp # exp'
+            HsEnumFromThen  exp exp' ->
+                HsEnumFromThen  # exp # exp'
+            HsEnumFromThenTo  exp exp' exp'' ->
+                HsEnumFromThenTo  # exp # exp' # exp''
+            HsListComp  exp stmts ->
+                HsListComp  # exp # stmts
+            HsExpTypeSig  srcloc exp qualtyp ->
+                HsExpTypeSig  # srcloc # exp # qualtyp
+            HsAsPat  name exp		 ->
+                HsAsPat  # name # exp		
+            HsWildCard x 	      	 ->
+                HsWildCard x			
+            HsIrrPat  exp		 ->
+                HsIrrPat  # exp		
+
+instance Renameable HsPat where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsPVar  name ->
+                HsPVar  # name
+            HsPLit  literal ->
+                HsPLit  # literal
+            HsPNeg  pat ->
+                HsPNeg  # pat
+            HsPInfixApp  pat name pat' ->
+                HsPInfixApp  # pat # name # pat'
+            HsPApp  name pats ->
+                HsPApp  # name # pats
+            HsPTuple  pats ->
+                HsPTuple  # pats
+            HsPList  pats ->
+                HsPList  # pats
+            HsPParen  pat ->
+                HsPParen  # pat
+            HsPRec  name patfields ->
+                HsPRec  # name # patfields
+            HsPAsPat  name pat ->
+                HsPAsPat  # name # pat
+            HsPWildCard  ->
+                HsPWildCard 
+            HsPIrrPat  pat ->
+                HsPIrrPat  # pat
+
+
+instance Renameable HsPatField where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+{-
+            HsPFieldPun  name ->
+                HsPFieldPun  # name
+-}
+            HsPFieldPat  name pat ->
+                HsPFieldPat  # name # pat
+
+
+instance Renameable (HsStmt) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsGenerator  srcloc pat exp ->
+                HsGenerator  # srcloc # pat # exp
+            HsQualifier  exp ->
+                HsQualifier  # exp
+            HsLetStmt  objects ->
+                HsLetStmt  # objects
+
+
+instance Renameable (HsFieldUpdate) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+{-
+            HsFieldBind  name ->
+                HsFieldBind  # name
+-}
+            HsFieldUpdate  name exp ->
+                HsFieldUpdate  # name # exp
+
+
+instance Renameable (HsAlt) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsAlt  srcloc pat guardedalts objects ->
+                HsAlt  # srcloc # pat # guardedalts # objects
+
+
+instance Renameable (HsGuardedAlts) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsUnGuardedAlt  exp ->
+                HsUnGuardedAlt  # exp
+            HsGuardedAlts   guardedalts ->
+                HsGuardedAlts  # guardedalts
+
+instance Renameable (HsGuardedAlt) where
+    replaceName f object
+      = let a # b = a $ (replaceName f b)
+        in case object of
+            HsGuardedAlt  srcloc exp exp' ->
+                HsGuardedAlt  # srcloc # exp # exp'
+
+instance Renameable HsName where 
+    replaceName f name = f name
+
+instance (Renameable a, Renameable b) => Renameable (a,b) where
+    replaceName f (x,y) = (replaceName f x, replaceName f y)
+instance Renameable a => Renameable [a] where
+    replaceName f xs = map (replaceName f) xs
+
+
+-- Ident table stuff
+type IdentTable = FiniteMap HsName (SrcLoc, Binding) 
+addToIdentTable _ _ = return ()
+
+{-
+printIdentTable :: IdentTable -> IO ()
+printIdentTable idt
+   = putStr $ unlines $ map showIdentTabEntry $ toListFM idt 
+   where
+   showIdentTabEntry :: (HsName, (SrcLoc, Binding)) -> String
+   showIdentTabEntry (name, (SrcLoc fn row col, bind)) 
+      = lJustify 40 (fromHsName name) ++ 
+        fn ++ ":" ++ showPos (row, col) ++ 
+        rJustify 10 (show bind)
+   showPos pos@(row, col)
+      | row < 0 || col < 0 = rJustify 10 "none" 
+      | otherwise          = rJustify 10 $ show pos 
+
+-- returns the binding type of a given identifier
+
+bindOfId :: IdentTable -> HsName -> Binding
+bindOfId idtab i
+   = case lookupFM idtab i of 
+        Nothing -> error $ "bindOfId: could not find binding for this identifier: " ++ show i
+        Just (_sloc, bind) -> bind
+addToIdentTable :: HsName -> (SrcLoc,Binding) -> ScopeSM ()
+addToIdentTable hsName srcLocAndBinding
+   = modify (\state -> state {identTable = addToFM (identTable state) hsName srcLocAndBinding })
+-}
addfile ./FrontEnd/TypeUtils.hs
hunk ./FrontEnd/TypeUtils.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              The Hatchet Team (see file Contributors)
+
+        Module:                 TypeUtils
+
+        Description:            Utility functions for manipulating types,
+                                and converting between the syntactic
+                                representation of types and the internal
+                                representation of types.
+
+        Primary Authors:        Bernie Pope
+
+        Notes:                  See the file License for license information
+
+-------------------------------------------------------------------------------}
+
+module TypeUtils (aHsTypeToType,
+                  aHsTypeSigToAssumps,
+                  aHsAsstToPred,
+                  flattenLeftTypeApplication) where
+
+import HsSyn    
+import Representation      
+
+import Type                     (tv, 
+                                 quantify, 
+                                 makeAssump,
+                                 assumpScheme,
+                                 tTTuple,
+                                 assumpId)
+
+import Utils   (fromHsName)
+import KindInfer                (KindEnv, 
+                            --     kiHsQualType,
+                                hsQualTypeToScheme,
+                                 kindOf)
+import Atom
+import Control.Monad.Identity
+
+-------------------------------------------------------------------------------------------
+--
+--  The conversion functions:
+--
+--    aHsTypeToType
+
+--------------------------------------------------------------------------------
+    
+-- note that the types are generated without generalised type
+-- variables, ie there will be no TGens in the output
+-- to get the generalised variables a second phase
+-- of generalisation must be applied
+
+aHsTypeToType :: KindEnv -> HsType -> Type
+
+-- arrows
+
+aHsTypeToType kt (HsTyFun t1 t2)
+   = aHsTypeToType kt t1 `fn` aHsTypeToType kt t2
+
+-- tuples
+
+aHsTypeToType kt tuple@(HsTyTuple types)
+   = tTTuple $ map (aHsTypeToType kt) types
+
+-- application
+
+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 $ tyvar  name (kindOf name kt)
+
+-- 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 name (kindOf name kt)
+
+aHsQualTypeToQualType :: KindEnv -> HsQualType -> Qual Type
+aHsQualTypeToQualType kt (HsQualType cntxt t)
+   = map (aHsAsstToPred kt) cntxt :=> aHsTypeToType kt t
+aHsQualTypeToQualType kt (HsUnQualType t)
+   = [] :=> aHsTypeToType kt t
+
+-- this version quantifies all the type variables
+-- perhaps there should be a version that is 
+-- parameterised with which variables to quantify
+
+aHsQualTypeToScheme :: KindEnv -> HsQualType -> Scheme
+aHsQualTypeToScheme kt qualType
+   = quantify vars qt
+   where
+   qt = aHsQualTypeToQualType kt qualType
+   vars = tv qt 
+
+-- one sig can be given to multiple names, hence
+-- the multiple assumptions in the output
+
+{-
+aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [Assump]
+aHsTypeSigToAssumps kt sig@(HsTypeSig _ names qualType)
+   = [n :>: scheme | n <- names]
+   where
+   scheme = aHsQualTypeToScheme newEnv qualType 
+   --newEnv = kiHsQualType kt qualType 
+   newEnv = kt
+-}
+
+
+
+aHsAsstToPred :: KindEnv -> HsAsst -> Pred
+aHsAsstToPred kt (className, varName)
+   -- = IsIn className (TVar $ Tyvar varName (kindOf varName kt)) 
+   = IsIn className (TVar $ tyvar varName (kindOf className kt)) 
+
+-- one sig can be given to multiple names, hence
+-- the multiple assumptions in the output
+
+aHsTypeSigToAssumps :: KindEnv -> HsDecl -> [Assump]
+aHsTypeSigToAssumps kt sig@(HsTypeSig _ names qualType) = [n :>: scheme | n <- names] where
+    Identity scheme = hsQualTypeToScheme kt qualType
+   --scheme = aHsQualTypeToScheme newEnv qualType 
+   --newEnv = kiHsQualType kt qualType 
+
+{-
+   converts leftmost type applications into lists
+
+   (((TC v1) v2) v3) => [TC, v1, v2, v3]
+
+-}
+flattenLeftTypeApplication :: HsType -> [HsType]
+flattenLeftTypeApplication t
+   = flatTypeAcc t []
+   where
+   flatTypeAcc (HsTyApp t1 t2) acc
+      = flatTypeAcc t1 (t2:acc)
+   flatTypeAcc nonTypApp acc
+      = nonTypApp:acc
+
+-- qualifies a type assumption to a given module, unless
+-- it is already qualified
+
+qualifyAssump :: Module -> Assump -> Assump 
+qualifyAssump mod assump
+   | isQual ident = assump  -- do nothing 
+   | otherwise = makeAssump newQualIdent scheme
+   where
+   scheme :: Scheme
+   scheme = assumpScheme assump
+   ident :: HsName
+   ident = assumpId assump 
+   newQualIdent :: HsName
+   newQualIdent = Qual mod $ HsIdent $ fromHsName ident
addfile ./FrontEnd/Unlit.hs
hunk ./FrontEnd/Unlit.hs 1
+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 (('#':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:))
+
addfile ./FrontEnd/Utils.hs
hunk ./FrontEnd/Utils.hs 1
+{-------------------------------------------------------------------------------
+
+        Copyright:              The Hatchet Team (see file Contributors)
+
+        Module:                 Utils
+
+        Description:            Generic utilities that don't have a good home 
+                                anywhere else.
+
+        Primary Authors:        Bernie Pope
+
+        Notes:                  See the file License for license information
+
+-------------------------------------------------------------------------------}
+
+module Utils where
+
+import HsSyn   
+import Char             
+--import PPrint (PPrint (..),vcat)
+import Control.Monad.Identity
+import Doc.DocLike
+import Doc.PPrint
+import VConsts
+import Name
+import qualified Data.Map as Map
+
+
+
+
+
+instance FromTupname HsName where 
+    fromTupname (Qual (Module "Prelude") (HsIdent xs))  = fromTupname xs
+    fromTupname _ = fail "fromTupname: not Prelude"
+
+instance ToTuple HsName where
+    toTuple n = (Qual (Module "Prelude") (HsIdent $ toTuple n))
+
+--------------------------------------------------------------------------------
+
+--getAModuleName :: HsModule -> Module
+--getAModuleName (HsModule modName _ _ _) = modName
+
+getDeclNames ::  HsDecl -> [HsName]
+getDeclNames (HsTypeSig _ ns _ ) =  ns
+getDeclNames d = maybeGetDeclName d
+
+maybeGetDeclName :: Monad m => HsDecl -> m HsName
+maybeGetDeclName (HsPatBind sloc (HsPVar name) rhs wheres) = return name
+maybeGetDeclName (HsFunBind ((HsMatch _ name _ _ _):_)) = return name
+maybeGetDeclName (HsDataDecl _ _ name  _ _ _) = return name
+maybeGetDeclName (HsNewTypeDecl _ _ name  _ _ _) = return name
+maybeGetDeclName (HsClassDecl _ qualType _)
+   = case qualType of
+        HsQualType _cntxt t
+           -> return $ leftMostTyCon t
+        HsUnQualType t
+           -> return $ leftMostTyCon t 
+maybeGetDeclName (HsForeignDecl _ _ _ n _) = return n
+--maybeGetDeclName (HsTypeSig _ [n] _ ) = return n
+maybeGetDeclName d = fail  $ "getDeclName: could not find name for a decl: " ++ show d 
+
+getDeclName d =  runIdentity $ maybeGetDeclName d 
+
+--getDeclName :: HsDecl -> HsName
+--getDeclName (HsPatBind sloc (HsPVar name) rhs wheres) = name
+--getDeclName (HsFunBind ((HsMatch _ name _ _ _):_)) = name
+--getDeclName (HsDataDecl _ _ name  _ _ _) = name
+--getDeclName (HsNewTypeDecl _ _ name  _ _ _) = name
+--getDeclName (HsClassDecl _ qualType _)
+--   = case qualType of
+--        HsQualType _cntxt t
+--           -> leftMostTyCon t
+--        HsUnQualType t
+--           -> leftMostTyCon t
+--getDeclName (HsForeignDecl _ _ _ n _) = n
+--getDeclName d = error $ "getDeclName: could not find name for a decl: " ++ show d 
+
+
+-- gets the left most type constructor from a type
+
+--leftMostTyCon (HsTyTuple ts) = error "leftMostTyCon: applied to a tuple"
+leftMostTyCon (HsTyTuple ts) = toTuple (length ts)
+leftMostTyCon (HsTyApp t1 _) = leftMostTyCon t1 
+leftMostTyCon (HsTyVar _) = error "leftMostTyCon: applied to a variable"
+leftMostTyCon (HsTyCon n) = n
+
+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
+
+
+
+fromHsName :: HsName -> String
+fromHsName (UnQual i) = hsIdentString i 
+fromHsName (Qual (Module m) i) = m ++ "." ++ (hsIdentString i)
+
+fromHsIdentifier :: HsIdentifier -> String
+fromHsIdentifier = hsIdentString
+
+isBindDecl :: HsDecl -> Bool
+isBindDecl HsPatBind {} = True
+isBindDecl HsFunBind {} = True 
+isBindDecl _ = False
+
+
+isSigDecl :: HsDecl -> Bool
+isSigDecl HsTypeSig {} = True
+isSigDecl _ = False
+
+fst3 :: (a,b,c) -> a
+fst3 (a,_,_) = a
+snd3 :: (a,b,c) -> b
+snd3 (_,b,_) = b
+trd3 :: (a,b,c) -> c
+trd3 (_,_,c) = c
+
+-- takes a list of things and puts a seperator string after each elem
+-- except the last, first arg is a function to convert the things into
+-- strings
+showListAndSep :: (a -> String) -> String -> [a] -> String
+showListAndSep f sep [] = []
+showListAndSep f sep [s] = f s
+showListAndSep f sep (s:ss) = f s ++ sep ++ showListAndSep f sep ss
+
+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)]
+
+-- an infinite list of alphabetic strings in the usual order
+nameSupply :: [String]
+nameSupply
+  = [ x++[y] | x <- []:nameSupply, y <- ['a'..'z'] ]
+
+nameOfTyCon :: HsType -> HsName
+nameOfTyCon (HsTyCon n) = n
+nameOfTyCon (HsTyTuple xs) = toTuple (length xs)
+nameOfTyCon (HsTyFun _ _) = hsTypName ("Prelude","->")
+nameOfTyCon t = error $ "nameOfTyCon: " ++ show t
+
+groupEquations :: [HsDecl] -> [(HsName, HsDecl)]
+groupEquations [] = []
+groupEquations (d:ds)
+   = (getDeclName d, d) : groupEquations ds 
+
+spacesToUnderscores :: String -> String
+spacesToUnderscores 
+   = map $ \c -> if (isSpace c) then '_' else c
+
+rJustify :: Int -> String -> String
+rJustify n s = replicate (n - length s) ' ' ++ s
+
+lJustify :: Int -> String -> String
+lJustify n s = take n $ s ++ repeat ' ' 
+
+
+
+
+
+
+-- module qualifies a name if it isn't already qualified
+
+qualifyName :: Module -> HsName -> HsName
+qualifyName _ name@(Qual {}) = name
+qualifyName mod (UnQual name) = Qual mod name
+
+qualifyName' :: Module -> HsName -> HsName
+qualifyName' mod (Qual _ name) = Qual mod name
+qualifyName' mod (UnQual name) = Qual mod name
+
+unqualifyName :: HsName -> HsName
+unqualifyName (Qual _ n)  = UnQual n
+unqualifyName n = n
+
+-- -- The possible bindings for names 
+
+data Binding
+   = TopFun             -- function binding at the top level
+   | ClassMethod        -- name of a method in a class
+   | Instance           -- an instance decl lifted to a top-level binding
+   | WhereFun           -- function binding in a where clause
+   | LetFun             -- function binding in a let expression (used to include topbinds too)
+   | LamPat             -- pattern binding in a lambda expression
+   | CasePat            -- pattern binding in a case expression
+   | GenPat             -- pattern binding in a generator statement
+   | FunPat             -- pattern binding in a function declaration
+   | Constr             -- name is a data constructor 
+   deriving (Show, Eq, Enum)
+
+-- 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 
+--   pprint (HsSymbol  s) = text s 
+--   pprint (HsSpecial s) = text s 
+
+
+pprintEnvMap m = vcat [ pprint x <+> text "::" <+> pprint y | (x,y) <- Map.toList m ]
addfile ./FrontEnd/Warning.hs
hunk ./FrontEnd/Warning.hs 1
+module Warning(Warning(..), MonadWarn(..), processErrors, warn, warnF, err, addDiag, addWarn, processIOErrors) where
+
+import HsSyn
+import List
+import GenUtil
+import Options
+import Control.Monad.Writer
+import System.IO.Unsafe
+import Data.IORef
+import Control.Monad.Identity
+
+{-# NOINLINE ioWarnings #-}
+ioWarnings :: IORef [Warning]
+ioWarnings = unsafePerformIO $ newIORef []
+
+
+data Warning = Warning { warnSrcLoc :: !SrcLoc, warnType :: String, warnMessage :: String }
+    deriving(Eq,Ord)
+
+class Monad m => MonadSrcLoc m where
+    getSrcLoc :: m SrcLoc
+
+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 ws
+    writeIORef ioWarnings []
+
+processErrors :: [Warning] -> IO ()
+processErrors ws = mapM_ s ws' >> when die exitFailure 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" ]
+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")
+    ]
+
+
addfile ./GenUtil.hs
hunk ./GenUtil.hs 1
+
+--  $Id: GenUtil.hs,v 1.40 2005/02/02 11:55:22 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,
+    -- ** System routines
+    exitSuccess, System.exitFailure, epoch, lookupEnv,endOfTime,
+    -- ** Random routines
+    repMaybe,
+    liftT2, liftT3, liftT4, 
+    snub, snubFst, sortFst, groupFst, foldl',
+    fmapLeft,fmapRight,isDisjoint,isConjoint,
+    groupUnder,
+    sortUnder,
+    minimumUnder,
+    maximumUnder,
+    sortGroupUnder,
+    sortGroupUnderF,
+    sortGroupUnderFG,
+
+    -- ** Monad routines
+    repeatM, repeatM_, replicateM, replicateM_, maybeToMonad,
+    toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_,
+    -- ** Text Routines
+    -- *** Quoting
+    shellQuote, simpleQuote, simpleUnquote, 
+    -- *** Layout
+    indentLines,
+    buildTableLL,
+    buildTableRL,
+    buildTable,
+    trimBlankLines,
+    paragraph,
+    paragraphBreak,
+    expandTabs,
+    chunkText,
+    -- ** Random
+    concatInter,
+    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,
+
+
+    -- * Classes
+    UniqueProducer(..)
+    ) where
+
+import Char(isAlphaNum, isSpace, toLower,  ord)
+import List(group,sort)
+import List(intersperse, sortBy, groupBy, transpose)
+import Monad
+import qualified IO
+import qualified System
+import Random(StdGen, newStdGen, Random(randomR))
+import Time
+import CPUTime
+
+{-# SPECIALIZE snub :: [String] -> [String] #-}
+{-# SPECIALIZE snub :: [Int] -> [Int] #-}
+
+-- | 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)
+
+-- | 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)
+
+-- | 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)
+
+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 f [] = error "minimumUnder: empty list"
+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 f [] = error "maximumUnder: empty list"
+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
+
+--    peekUniq :: m Int
+--    modifyUniq :: (Int -> Int) -> m ()
+--    newUniq = do
+--	v <- peekUniq
+--	modifyUniq (+1) 
+--	return v
+
+rtup a b = (b,a)
+triple a b c = (a,b,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
+
+{-# 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
+
+{-# SPECIALIZE maybeToMonad :: Maybe a -> IO a #-}
+-- | convert a maybe to an arbitrary failable monad
+maybeToMonad :: Monad m => Maybe a -> m a
+maybeToMonad (Just x) = return x
+maybeToMonad Nothing = fail "Nothing"
+
+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          [] = ([],[])
+
+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 mw s | length s < mw = [s]
+chunk mw s = case splitAt mw s of (a,b) -> a : chunk mw b
+
+chunkText :: Int -> String -> String 
+chunkText mw s = concatMap (unlines . chunk mw) $ lines s
+
+{-
+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 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. 
+concatInter :: String -> [String] -> String
+concatInter x = concat . (intersperse x)
+
+-- | 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 $ reverse (tb $ reverse (tb (lines cs))) where
+    tb = dropWhile (all isSpace)
+
+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 = length . filter f 
+
+-- | 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 = concatInter " " [  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 (p:ps) (s:ss) 
+        | p == s = f ps ss  
+        | otherwise = fail $ "getPrefix: " ++ a ++ " " ++ b 
+
addfile ./GraphUtil.hs
hunk ./GraphUtil.hs 1
+-- | Data.Graph is sorely lacking in several ways, This just tries to fill in
+-- some holes and provide a more convinient interface
+
+module GraphUtil where
+
+import qualified Data.Graph 
+import Data.Graph hiding(Graph)
+import GenUtil
+import Array
+--import qualified Map
+import List(sort,sortBy,group,delete)
+
+
+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 (GraphUtil.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
+    --kv a = Map.lookup a $ Map.fromList $  zip (sort $ map fn ns) [0..] 
+
+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
+    -> Graph n k  -- ^ the graph
+    ->  ([n],[n]) -- ^ (loop breakers,dependency ordered nodes after loopbreaking)
+findLoopBreakers func (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,_):_) = sortBy (\ a b -> compare (snd b) (snd a)) [ (v,func (ln v)) | v <- ns]  
+            ns = dec n []
+            -- ng =  -- (g // [(n,[ x | x <- g!n, x /= mv]) | n <- ns])
+            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 (GraphUtil.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
+
+
+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 <- GraphUtil.scc g] 
+
+--reachable :: Graph n k -> [k] -> [k]
addfile ./Grin/DeadFunctions.hs
hunk ./Grin/DeadFunctions.hs 1
+module Grin.DeadFunctions(deadFunctions) where 
+
+
+import Atom
+import CharIO
+import Control.Monad.Identity
+import Control.Monad.Writer
+import Data.Graph
+import Data.Monoid
+import FindFixpoint
+import FreeVars
+import GenUtil hiding(replicateM_)
+import Grin.Grin
+import Grin.Whiz 
+import MonoidUtil()
+import List
+import Monad
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Seq
+import Stats
+
+concatMapM f xs = liftM concat $ mapM f xs 
+
+data ArgInfo = Used | Unused | Passed [(Atom,Int)]
+    deriving(Eq,Ord,Show)
+
+instance Monoid ArgInfo where
+    mempty = Unused 
+    mappend Unused b = b
+    mappend b Unused = b
+    mappend Used _ = Used
+    mappend _ Used = Used
+    mappend (Passed xs) (Passed ys) = Passed (snub (xs ++ ys))
+
+data FunctionInfo = FunctionInfo {
+    functionName :: Atom,
+    functionBody :: Lam,
+    functionArity :: Int,
+    functionUnusedArgs :: [Int],
+    functionArgInfo :: [ArgInfo],
+    functionCafsUsed :: [Var],
+    functionCalls :: [Atom] 
+}
+
+
+instance Show FunctionInfo where
+    showsPrec d (FunctionInfo aa ab ac ad bb ae af) = showParen (d >= 10)
+              (showString "FunctionInfo" . showChar '{' .
+               showString "functionName" . showChar '=' . showsPrec 10 aa
+               . showChar ',' . showChar '\n' .
+               showString "functionArity" . showChar '=' . showsPrec 10 ac
+               . showChar ',' . showChar '\n' .
+               showString "functionUnusedArgs" . showChar '=' . showsPrec 10 ad
+               . showChar ',' . showChar '\n' .
+               showString "functionArgInfo" . showChar '=' . showsPrec 10 bb
+               . showChar ',' . showChar '\n' .
+               showString "functionCafsUsed" . showChar '=' . showsPrec 10 ae
+               . showChar ',' . showChar '\n' .
+               showString "functionCalls" . showChar '=' . showsPrec 10 af
+               . showChar '}' . showChar '\n')
+
+
+getFunctionInfo cafs indirect (a,b@(Tup as :-> e)) = FunctionInfo {
+    functionName = a,
+    functionBody = b,
+    functionArity = length as,
+    functionUnusedArgs = uuargs,
+    functionArgInfo = arginfo,
+    functionCafsUsed = cused,
+    functionCalls = fc
+
+    }  where
+        fc | indirect =  snub $ concatMap tagToFunction (Set.toList ts) ++ ef
+           | otherwise = filter tagIsFunction (Set.toList ts)
+        (vs,ts) = freeVars e
+        ef =  concatMap tagToFunction  (freeVars (nc)) 
+        uuargs = [ i | (Var v _,i) <- zip as [0..], not $ v `Set.member` vs]
+        cused = [ v | v@(V n) <- Set.toList vs, n < 0 ]
+        arginfo = collectArgInfo b
+        nc = [ y | (x,y) <- cafs, x `elem` cused ]
+
+
+-- | Remove dead functions
+
+deadFunctions :: 
+    Bool       -- ^ Whether to count indirect function calls. (used before eval\/apply inlining)
+    -> Stats   -- ^ stats to update with what was done
+    -> [Atom]  -- ^ roots 
+    -> Grin    -- ^ input 
+    -> IO Grin -- ^ output
+deadFunctions indirect stats keeps grin = do
+    let (graph,lv,kv) = graphFromEdges [ (gf, functionName gf, functionCalls gf) |  gf <- map (getFunctionInfo (grinCafs grin) indirect) $ grinFunctions grin ]
+        reach = [ x|  (x,_,_) <- map lv $ snub $ concatMap (reachable graph) (map la keeps)]  
+        rs = Set.fromList (map functionName reach) 
+        --la a = case Map.lookup a $ Map.fromList $  zip (sort $ fsts (grinFunctions grin)) [0..] of
+        la a = case kv a  of
+            Just n -> n
+            Nothing -> error $ "DeadFunctions, CannotFind: " ++ show a
+        fs =  [ f | f@(a,_) <- grinFunctions grin, a `Set.member` rs ]
+        cu = Set.fromList $ concatMap functionCafsUsed reach
+        (nc,uuc) = List.partition ((`Set.member` cu) . fst)  (grinCafs grin)
+    replicateM_ (length (grinFunctions grin) - length reach) $ tick stats $ (toAtom "Optimize.dead-function") 
+    --CharIO.putStr "Dead Functions: "
+    --CharIO.print [ a | (a,_) <- grinFunctions grin, not $ a `Set.member` rs ] 
+    --mapM cleanupDeadArgs 
+    --let f n | null $ functionUnusedArgs n = ""
+    --        | otherwise = show (functionName n) ++ show (functionUnusedArgs n) ++ "\n"
+    --mapM (CharIO.putStr . f) reach
+    when (not $ null uuc) $ do
+        replicateM_ (length uuc) $ tick stats $ (toAtom "Optimize.caf-cleanup") 
+        --CharIO.putStr "Dead Cafs: "
+        --CharIO.print uuc
+    --mapM_ CharIO.print reach
+    reach <- findDeadCode stats  reach 
+        
+    fs <- mapM (removeDeadArgs stats reach) fs
+    return $ grin { grinFunctions = fs, grinCafs = nc }
+
+
+{-
+class  FixIn b a | b -> a where 
+    getSafeDependencies :: Maybe (b -> [a])
+    getSafeDependencies = Nothing
+-}
+
+
+findFixpoint :: (Show a,Ord a,Eq b,Monoid b) => Maybe String -> (x -> a) -> ((a -> Ms b b) -> x -> Ms b b) -> [x] -> IO [(x,b)]  
+findFixpoint str en fn xs = ans where
+    ans = do
+        rs <- solve str mempty is
+        return $ zip xs rs
+    mp = Map.fromList [ (en x,i) | x <- xs | i <- [0..]]
+    f a | Just x <- Map.lookup a mp = getVal x
+    f a | otherwise = return $ mempty
+    f a | otherwise = error $ "findFixpoint: Cannot find " ++ show a 
+    is = map (fn f) xs 
+    
+    
+    
+
+findDeadCode stats fs = ans where 
+    is = [ ((functionName f,i),functionArgInfo f !! i) | f <- fs, i <- [0 .. functionArity f - 1]  ]
+    ans = do
+        zs <- findFixpoint Nothing fst c is
+        ua <- concatMapM rs zs
+        let mp = Map.fromList $ [ (x,snds xs) | (x,xs) <- sortGroupUnderF fst ua]
+            z f | Just x <- Map.lookup (functionName f) mp = f { functionUnusedArgs = x }
+            z f@(FunctionInfo { functionUnusedArgs = [] }) = f 
+        return $ map z fs 
+    st = Set.fromList $ map functionName fs
+    c getVal (_,f) = g getVal f
+    g getVal Used = return True
+    g getVal Unused = return False
+    g getVal (Passed xs) | any (not . (`Set.member` st)) (fsts xs) = return True
+    g getVal (Passed xs)  = mapM getVal xs >>= return . or
+    rs ((x,Passed _), False) = do
+        --CharIO.print x
+        tick stats $ toAtom "Optimize.rec-dead-arg"
+        rs' (x,False) 
+    rs ((x,_),y) = rs' (x,y)
+    rs' (x,True) = return []
+    rs' (x,False) = return [x]
+    
+
+pHole = Const (NodeC tagHole [])
+
+removeDeadArgs stats fs (a,l) =  whizExps f l >>= return . (,) a where
+    f (App fn as) = do
+        as <- dff fn as
+        return $ App fn as
+    f (Return (NodeC fn as)) | Just fn' <- tagToFunction fn = do
+        as <- dff fn' as 
+        return $ Return (NodeC fn as)
+    f (Store (NodeC fn as)) |  Just fn' <- tagToFunction fn = do
+        as <- dff fn' as 
+        return $ Store (NodeC fn as)
+    f (Update p (NodeC fn as)) |  Just fn' <- tagToFunction fn = do
+        as <- dff fn' as 
+        return $ Update p (NodeC fn as)
+    f x = return x
+    dff fn as = mapM df  (zip as [0..]) where
+        xs = lup fn 
+        df (a,i) | a /= pHole && i `elem` xs  = do
+            tick stats $ toAtom "Optimize.dead-arg"
+            return pHole
+            --return $ Const (NodeC (toAtom $ "@hole:" ++ show (fn,i)) [])-- pHole
+        df (a,_)  = return a
+    lup fn = case Map.lookup fn m of
+        Just x -> x
+        Nothing -> []
+    m = Map.fromList [  (functionName x,functionUnusedArgs x) | x <- fs, not $ null (functionUnusedArgs x) ]
+    
+groupConcatFst xs = [ (x,mconcat $ snds xs) | (x,xs) <- sortGroupUnderF fst xs] 
+        
+-- TODO make this see through store and fetches
+collectArgInfo :: Lam -> [ArgInfo]
+collectArgInfo exp@(Tup as :-> _) = ans where   
+    ws = Map.fromList $ groupConcatFst $ Seq.toList $ execWriter (whizExps f exp) 
+    lv x = case Map.lookup x ws of 
+        Just x -> x
+        Nothing -> Unused
+    ans = [ lv x |  Var x _ <- as ]
+    f e = g e >> return e 
+    g (App a [e]) | a == funcEval =  tell (Seq.fromList [ (v,Used) | v <- freeVars e ])
+    g (App a [x,y]) | a == funcApply =  tell (Seq.fromList [ (v,Used) | v <- freeVars (x,y) ])
+    g (App a vs) = tell (Seq.fromList $ concat [ [ (x,Passed [(a,i)]) | x <- freeVars v] | v <- vs | i <- [0..] ])
+    g (Store (NodeC x vs)) | Just a <- tagToFunction x = tell (Seq.fromList $ concat [ [ (x,Passed [(a,i)]) | x <- freeVars v] | v <- vs | i <- [0..] ])
+    g (Return (NodeC x vs)) | Just a <- tagToFunction x = tell (Seq.fromList $ concat [ [ (x,Passed [(a,i)]) | x <- freeVars v] | v <- vs | i <- [0..] ])
+    g (Update _ (NodeC x vs)) | Just a <- tagToFunction x = tell (Seq.fromList $ concat [ [ (x,Passed [(a,i)]) | x <- freeVars v] | v <- vs | i <- [0..] ])
+    g (Case e _) = tell (Seq.fromList [ (v,Used) | v <- freeVars e ])
+    g e = tell (Seq.fromList [ (v,Used) | v <- freeVars e ])
+    g _ = return ()
+    
+    
addfile ./Grin/EvalInline.hs
hunk ./Grin/EvalInline.hs 1
+module Grin.EvalInline(
+    createEval, 
+    createApply,
+    UpdateType(..)
+    ) where
+
+
+import Grin.Grin
+import Control.Monad.Identity
+import Atom
+import Char
+
+data UpdateType = NoUpdate | TrailingUpdate | HoistedUpdate Val 
+
+-- 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
+    | 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])
+    | otherwise = p1 :->
+        Fetch p1 :>>= n2 :->
+        Case n2 cs 
+    where
+    cs = [f t | t <- ts, tagIsTag t, isGood t ]
+    isGood t | tagIsWHNF t, HoistedUpdate (NodeC t' _) <- shared, t /= t' = False
+    isGood _ = True
+    g t vs
+        | tagIsWHNF t, HoistedUpdate (NodeC t' [v]) <- shared  = case vs of
+            [x] -> Return x
+            _ -> error "createEval: bad thing"
+        | tagIsWHNF t = Return n2
+        | '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 [v]) <- shared = App (toAtom n) vs :>>= n3 :-> Return n3 :>>= udp :-> Update p1 udp :>>= unit :-> Return v
+        | HoistedUpdate udp <- shared = App (toAtom n) vs :>>= n3 :-> (Return n3 :>>= udp :-> Update p1 udp) :>>= unit :-> Return n3
+        | otherwise = App (toAtom n) vs
+
+createApply :: TyEnv -> [Tag] -> Lam
+createApply te ts
+    | null cs = Tup [n1,p2] :-> Error ("Empty Apply:" ++ show ts)  TyNode
+    | otherwise = Tup [n1,p2] :-> Case n1 cs
+    where
+    cs = [ f t | t <- ts, tagIsPartialAp t]
+    f t = (NodeC t vs :-> g ) where
+        (ts,_) = runIdentity $ findArgsType te t
+        vs = [ Var v ty |  v <- [v3 .. ] | ty <- ts]
+        ('P':cs) = fromAtom t
+        (n','_':rs) = span isDigit cs
+        n = read n'
+        g
+            | n == (1::Int) =  App (toAtom $ 'f':rs) (vs ++ [p2])
+            | n > 1 = Return $ NodeC (toAtom $ 'P':show (n - 1) ++ "_" ++ rs) (vs ++ [p2])
+            | otherwise = error "createApply"
addfile ./Grin/Fizz.hs
hunk ./Grin/Fizz.hs 1
+module Grin.Fizz(fizz) where
+
+import Grin.Grin
+import Grin.Whiz
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans
+import Data.Monoid
+import DDataUtil()
+import Control.Monad.Identity
+
+type WhizState = Either (Set.Set Int) Int
+type WhizEnv = Map.Map Var Val
+
+whizState :: WhizState
+whizState = Left mempty
+
+
+-- | 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 :: 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 ((v,b):xs) env
+    f a@(Return (Tup xs@(_:_))) ((p@(Tup ys@(_:_)),b):rs) env | length xs == length ys  = do
+        Return (Tup xs) <- g env a 
+        (Tup ys,env') <- renamePattern p
+        ts <- lift $ mapM te [(y,Return x) | x <- xs | y <- ys ] 
+        z <- f b rs (env' `mappend` env)
+        let h [] = z
+            h ((p,v):rs) = v :>>= p :-> h rs
+        return $ h [ (p,v) |  Just (p,v) <- ts]
+    f a ((p,b):xs) env = do
+        a <- g env a
+        (p,env') <- renamePattern p
+        x <- lift $ te (p,a)
+        z <- f b xs (env' `mappend` env) 
+        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 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 = f x where 
+    g = applySubst env
+    f (App a vs) = do
+        vs' <- mapM g vs
+        return $ App a vs'
+    f (Return v) = do
+        v <- g v
+        return $ Return v
+    f (Prim x vs) = do
+        vs <- mapM g vs
+        return $ Prim x vs
+    f (Store v) = do
+        v <- g v
+        return $ Store v
+    f (Fetch v) = do
+        v <- g v
+        return $ Fetch v
+    f (Update a b) = do
+        a <- g a
+        b <- g b
+        return $ Update a b
+    f e@Error {} = return e
+    f (Cast v t) = do 
+        v <- g v
+        return $ Cast v t
+    f (Case e as) = do 
+        e <- g e
+        return $ Case e as
+    f x = error $ "applySubstE: " ++ show x
+
+applySubst env x = f x where
+    f (Var v _) | Just n <- Map.lookup v env =  return n
+    f (NodeC t vs) = do
+        vs' <- mapM f vs
+        return $ NodeC t vs'
+    f (Tup vs) = do
+        vs' <- mapM f vs
+        return $ Tup vs'
+    f (NodeV t vs) | Just (Var t' _) <- Map.lookup t env = do
+        vs' <- mapM f vs
+        return $ NodeV t' vs'
+    f (NodeV t vs) = do
+        vs' <- mapM f vs
+        return $ NodeV t vs'
+    f Addr {} = error "Address in subst" 
+    f x = return x
+
+renamePattern :: MonadState (WhizState) m => Val ->  m (Val,WhizEnv) 
+renamePattern x = runWriterT (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.single v nv)
+        return nv
+    f (NodeC t vs) = do
+        vs' <- mapM f vs
+        return $ NodeC t vs'
+    f (Tup vs) = do
+        vs' <- mapM f vs
+        return $ Tup vs'
+    f (NodeV t vs) = do
+        t' <- lift $ newVarName t
+        tell (Map.single t (Var t' TyTag))
+        vs' <- mapM f vs
+        return $ NodeV t' vs'
+    f Addr {} = error "Address in pattern" 
+    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 + 1)
+                    | otherwise = n
+            put (Left $ Set.insert nv s)
+            return (V nv)
+        Right n -> do
+            put $! (Right $! (n + 1))
+            return $ V n
+    
+
+
addfile ./Grin/FromE.hs
hunk ./Grin/FromE.hs 1
+module Grin.FromE(compile,typecheckGrin) where
+
+import Atom
+import Char
+import Control.Monad.Identity
+import C.Prims
+import DataConstructors
+import Data.Graph(stronglyConnComp, SCC(..))
+import Data.IORef
+import Data.Map as Map hiding(map,null)
+import Data.Monoid
+import DDataUtil()
+import Doc.DocLike
+import Doc.PPrint
+import Doc.Pretty
+import E.E
+import E.LambdaLift
+import E.Pretty(render)
+import E.TypeCheck
+import E.Values
+import FreeVars
+import GenUtil
+import GraphUtil as G
+import Grin.Grin
+import Grin.Show
+import Grin.Val
+import List
+import Maybe
+import Monad
+import Name
+import Options
+import PrimitiveOperators
+import qualified Data.Set as Set
+import qualified FlagDump as FD
+import Stats
+import VConsts
+
+
+
+{- | 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
+-------------------
+
+
+
+data CEnv = CEnv {
+    scMap :: Map Int (Atom,[Ty],Ty), 
+    ccafMap :: Map Int Val,
+    tyEnv :: IORef TyEnv, 
+    funcBaps :: IORef [(Atom,Lam)],
+    constMap :: Map Int Val,
+    counter :: IORef Int
+
+}
+
+dumpTyEnv (TyEnv tt) = mapM_ putStrLn $ sort [ fromAtom n <+> hsep (map show as) <+> "::" <+> show t |  (n,(as,t)) <- Map.toList tt]
+
+--compile ::  DataTable -> Map Int Name -> SC -> IO ()
+--compile dataTable nmap sc@SC { scMain = mt, scCombinators = cm } = do
+--    where
+
+flattenScc xs = concatMap f xs where
+    f (AcyclicSCC x) = [x]
+    f (CyclicSCC xs) = xs
+
+partialLadder t 
+    | 'P':cs <- fromAtom t = let
+        (n','_':rs) = span isDigit cs
+        n = (read n' :: Int)
+        in [ toAtom $ 'P':show x ++ "_" ++ rs | x <- [1 .. n]]
+    | otherwise = [t]
+
+typecheckGrin grin = do
+    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,typecheck (grinTypeEnv grin) c:: Either String Ty)   | a@(_,(_ :-> c)) <-  grinFunctions grin ]]
+    mapM_ putErrLn  errs 
+    when (not $ null errs) $ fail "There were type errors!" 
+
+scTag n = t where (t,_,_) = toEntry (n,undefined,undefined)
+
+cafNum n = V $ - atomIndex (partialTag t 0) 
+    where 
+    (t,_,_) = toEntry (n,undefined,undefined)
+
+--toEntry (n,as,e) 
+--    --  | Just nm <- Map.lookup (tvrNum n) nmap = ((toAtom ('f':show nm)),map (const $ TyPtr TyNode) as,TyNode)
+--    | Just nm <- intToAtom (tvrNum n)  = ((toAtom ('f':show (fromAtom nm :: Name))),map (const $ TyPtr TyNode) as,TyNode)
+--    | otherwise = ((toAtom ('f':show (tvrNum n))),map (const $ TyPtr TyNode) as,TyNode)
+
+toEntry (n,as,e) 
+    | Just nm <- intToAtom (tvrNum n)  = f (toAtom ('f':show (fromAtom nm :: Name)))
+    | otherwise = f (toAtom ('f':show (tvrNum n))) where
+        f x = (x,map (toty (TyPtr TyNode) . tvrType ) as,toty TyNode (typ e))
+        toty node (ELit (LitCons n [] es)) |  es == eStar, RawType <- nameType n = (Ty $ toAtom (show n))
+        toty node _ = node
+
+
+compile ::  DataTable -> Map Int Name -> SC -> IO Grin
+compile dataTable nmap sc@SC { scMain = mt, scCombinators = cm } = do
+    tyEnv <- newIORef initTyEnv
+    funcBaps <- newIORef []
+    counter <- newIORef 100000  -- TODO real number
+    wdump FD.Tags $ do
+        dumpTyEnv initTyEnv
+    let (cc,reqcc) = constantCaf dataTable sc 
+    wdump FD.Progress $ do
+        putErrLn $ "Found" <+> tshow (length cc) <+> "CAFs to convert to constants," <+> tshow (length reqcc) <+> "of which are recursive."                                  
+        putDocMLn putStr $ vcat [ pprint v  | v <- reqcc ]
+        putDocMLn putStr $ vcat [ pprint v <+> pprint n <+> pprint e | (v,n,e) <- cc ]
+    let doCompile = compile' dataTable CEnv { 
+            funcBaps = funcBaps, 
+            tyEnv = tyEnv, 
+            scMap = scMap, 
+            counter = counter, 
+            constMap = mempty,
+            ccafMap = Map.fromList [ (tvrNum v,e) |(v,_,e) <- cc] 
+            }
+    ds <- mapM doCompile [ c | c@(v,_,_) <- cm, v `notElem` [x | (x,_,_) <- cc]]
+    (_,(Tup [] :-> theMain)) <- doCompile ((mt,[],EAp (EVar mt) vWorld__))
+    let tf a = a:tagToFunction a  
+    ds <- return $ flattenScc $ stronglyConnComp [ (a,x, concatMap tf (freeVars z)) | a@(x,(_ :-> z)) <- ds]
+    te <- readIORef tyEnv
+    fbaps <- readIORef funcBaps
+    --sequence_ [ typecheck te c >>= when False . print . (,) a  | (a,_,c) <-  ds ]
+    let (main,as,_) = runIdentity $ Map.lookup (tvrNum mt) scMap  
+        main' =  if not $ null as then  (Return $ NodeC (partialTag main (length as)) []) else App main []
+        tags = Set.toList $ ep $ Set.unions (freeVars (main',initCafs):[ freeVars e | (_,(_ :-> e)) <- ds ])
+        ep s = Set.fromList $ concatMap partialLadder $ Set.toList s
+        --ev = (funcEval,(Tup [p1] :-> createEval te tags))
+        --ap = (funcApply,(createApply te tags))  
+        cafs = [ ((V $ - atomIndex tag),NodeC tag []) | (x,(Tup [] :-> _)) <- ds, let tag = partialTag x 0 ] ++ [ (y,z') |(x,y,z) <- cc, y `elem` reqcc, let Const z' = z ]
+        initCafs = sequenceG_ [ Update (Var v (TyPtr TyNode)) node | (v,node) <- cafs ]
+        ic = (funcInitCafs,(Tup [] :-> initCafs) )
+        --ds' = ic:ev:ap:ds
+        ds' = ic:(ds ++ fbaps)
+    --wdump FD.Grin $ do
+        --mapM_ putStrLn [ show (x, freeVarsL z :: [Tag]) | (x,_,z) <- ds ]
+        --mapM_ (putErrLn . render) $ map prettyFun ds'
+    let grin = Grin { 
+            grinTypeEnv = te, 
+            --grinFunctions = (funcMain ,[], App funcInitCafs [] :>>= (Unit,Store main') :>>= (p1,gEval p1)): ds', 
+            --grinFunctions = (funcMain ,(Tup [] :-> App funcInitCafs [] :>>= unit :-> main' :>>= n3 :-> App funcApply [n3,pworld__] )) : ds', 
+            --grinFunctions = (funcMain ,(Tup [] :-> App funcInitCafs [] :>>= unit :->  main' :>>= n3 :-> App funcApply [n3,pworld__] :>>= n0 :-> Return unit )) : ds', 
+            grinFunctions = (funcMain ,(Tup [] :-> App funcInitCafs [] :>>= unit :->  theMain :>>= n0 :-> Return unit )) : ds', 
+            grinCafs = cafs -- [ (n,NodeC t []) | (n,t) <- cafs]
+            }
+    typecheckGrin grin
+    return grin 
+    where
+    scMap = fromList [ (tvrNum t,toEntry x) |  x@(t,_,_) <- scCombinators sc]
+    initTyEnv = mappend primTyEnv $ TyEnv $ fromList $ [ (a,(b,c)) | (_,(a,b,c)) <-  Map.toList scMap] ++ [con x| x <- Map.elems $ constructorMap dataTable] 
+    con c | (ELit (LitCons _ es t),_) <- fromLam $ conExpr c = let
+            n | sortStarLike (conType c) = toAtom ('T':show (conName c))
+              | otherwise = toAtom ('C':show (conName c))
+            as = [ TyPtr TyNode |  EVar tvr <- es] 
+        in  (n,(as,TyNode))
+    con c | (EPi (TVr { tvrType = a }) b,_) <- fromLam $ conExpr c = (tagArrow,([TyPtr TyNode, TyPtr TyNode],TyNode))
+         
+        {-
+    toTyEnv (n,Tup ps :-> e) = (n,(map (runIdentity . tc initTyEnv) ps,TyNode))
+    toEntry (n,as,e) 
+        | Just nm <- Map.lookup (tvrNum n) nmap = ((toAtom ('f':show nm)),map (toTy.tvrType) as,toTy (typ e))
+        | otherwise = ((toAtom ('f':show (tvrNum n))),map (toTy.tvrType) as,toTy (typ e))
+    scMap = fromList [ (tvrNum t,toEntry x) |  x@(t,_,_) <- scCombinators sc]
+    initTyEnv = TyEnv $ fromList $ [ (a,(b,c)) | (_,(a,b,c)) <-  Map.toList scMap] ++ [con x| x <- Map.elems $ constructorMap dataTable]
+    con c = (n,(as,toTy t)) where
+        n | sortStarLike (conType c) = toAtom ('T':show (conName c))
+          | otherwise = toAtom ('C':show (conName c))
+        as = [ toTy $ tvrType tvr |  EVar tvr <- es]
+        (ELit (LitCons _ es t),_) = fromLam $ conExpr c 
+        -}
+
+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)
+
+primTyEnv = TyEnv . Map.fromList $ [
+    --(toAtom "CChar",([tCharzh],TyNode)),
+    --(toAtom "CInt",([tIntzh],TyNode)),
+    (tagArrow,([TyPtr TyNode, TyPtr TyNode],TyNode)),
+    (toAtom "TAbsurd#", ([],TyNode)),
+    (funcInitCafs, ([],tyUnit)),
+    (funcEval, ([TyPtr TyNode],TyNode)),
+    (funcApply, ([TyNode, TyPtr TyNode],TyNode)),
+    (tagHole, ([],TyNode))
+    ] ++ [ (toAtom ('C':x), ([Ty $ toAtom y],TyNode)) | (x,y) <- allCTypes, y /= "void" ]
+
+
+-- 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. 
+
+--type ConstantCafMap = Map.Map Int -> Val
+--constantCaf :: DataTable -> SC -> [(TVr,Val)]
+constantCaf dataTable (SC _ ds) = ans where
+    (lbs',cafs) = G.findLoopBreakers (const 0) $ G.newGraph [ (v,e) | (v,[],e) <- ds, canidate e] (tvrNum . fst) (freeVars . snd)
+    lbs = Set.fromList $ fsts lbs'
+    canidate (ELit _) = True
+    canidate (EPi _ _) = True
+    canidate e | (EVar x,as) <- fromAp e, Just vs <- Map.lookup 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 ])
+    res = Map.fromList [ (v,length vs) | (v,vs,_) <- ds]
+    coMap = Map.fromList [  (v,ce)| (v,_,ce) <- fst ans] 
+    conv :: E -> Val
+    conv (ELit (LitInt i (ELit (LitCons n [] (ESort 0))))) | RawType <- nameType n =  Lit i (Ty $ toAtom (show n))
+    conv (ELit (LitInt i (ELit (LitCons n [] (ESort 0))))) | Just pt <- Prelude.lookup (show n) allCTypes = ( Const (NodeC (toAtom $ 'C':show n) [(Lit i (Ty (toAtom pt)))]))
+    conv e | Just (a,_) <- from_unsafeCoerce e = conv a
+--    conv e | Just (a,_) <- from_integralCast e = conv a
+    conv (ELit lc@(LitCons n es _)) | Just nn <- getName lc = (Const (NodeC nn (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 <- Map.lookup x res, vs > length as = Const (NodeC (partialTag (scTag x) (vs - length as)) (map conv as))
+    conv (EVar v) | Just ce <- Map.lookup v coMap = ce
+    conv (EVar v) = Var (cafNum v) (TyPtr TyNode)
+    getName = getName' dataTable
+                                        
+getName' :: (Show a,Monad m) => DataTable -> Lit a E -> m Atom 
+getName' dataTable v@(LitCons n es _) 
+    | conAlias cons = error $ "Alias still exists: " ++ show v 
+    | length es == nargs  = do
+        return cn
+    | nameType n == TypeConstructor && length es < nargs = do
+        return ((partialTag cn (nargs - length es)))
+    | otherwise = error $ "Strange name: " ++ show v ++ show nargs ++ show cons 
+    where
+    cn = convertName n
+    cons = runIdentity $ getConstructor n dataTable 
+    nargs = length (conSlots cons)
+
+instance ToVal TVr where
+    toVal (TVr { tvrIdent = num, tvrType = (ELit (LitCons n [] es))}) | es == eStar, RawType <- nameType n  = Var (V num) (Ty $ toAtom (show n))
+    toVal tvr = Var  (V (tvrNum tvr)) (TyPtr TyNode) -- (toTy $ tvrType tvr)
+
+-- constraints during compilation:
+-- 
+-- ce always produces something of type TyNode
+-- cc always produces something of type (TyPtr TyNode)
+-- all functions are assumed to return a TyNode 
+-- This is no longer true.
+-- 
+-- right after compilation, everything has type TyNode or (TyPtr TyNode) since 
+-- Haskell does not natively support anything other than boxed types.
+--
+
+dropCoerce e | Just (x,_) <- from_unsafeCoerce e = x
+--dropCoerce e | Just (x,_) <- from_integralCast e = x
+dropCoerce x = x
+
+compile' ::  DataTable -> CEnv -> (TVr,[TVr],E) -> IO (Atom,Lam) 
+compile' dataTable cenv (tvr,as,e) = cr e >>= \x -> return (nn,(Tup (map toVal as) :-> x)) where
+    funcName = maybe (show $ tvrNum tvr) show (fmap fromAtom ( intToAtom $ tvrNum tvr) :: Maybe Name) 
+    cc, ce, cr :: E -> IO Exp
+    (nn,_,_) = runIdentity $ Map.lookup (tvrNum tvr) (scMap cenv) 
+    cr x = ce x
+    ce (ELetRec ds e) = ce e >>= \e -> doLet ds e
+    ce (EError s e) = return (Error s TyNode)
+    ce (EVar tvr@(TVr { tvrType = (ELit (LitCons n [] _))})) | RawType <- nameType n = do
+        return (Return (toVal tvr))
+    ce e |  (v,as) <- fromAp e, EVar v <- dropCoerce v = do
+        as <- return $ args as 
+        case Map.lookup (tvrNum v) (scMap cenv) of
+            Just (_,[],_) -> do
+                case constant (EVar v) of 
+                    Just (Const x) -> app (Return x) as
+                    Just x@Var {} -> app (gEval x) as
+                    Nothing -> do
+                        var@Var {} <- caforconst (EVar v)
+                        app (gEval var) as   -- CAFs are looked up in global env  
+            Just (v,as',es) 
+                | length as >= length as' -> do
+                    let (x,y) = splitAt (length as') as
+                    app (App v x) y
+                | otherwise -> do
+                    let pt = partialTag v (length as' - length as)
+                    return $ Return (NodeC pt as)
+            Nothing -> app (gEval $ toVal v) as
+    ce e | (v,as@(_:_)) <- fromAp e = do
+        as <- return $ args as
+        e <- ce v
+        app e as
+    ce (EPi (TVr { tvrIdent = 0, tvrType = a}) b) = do
+        a' <- cc a
+        b' <- cc b 
+        p1 <- newNodePtrVar
+        p2 <- newNodePtrVar
+        return (a' :>>= p1 :-> b' :>>= p2 :-> Return (NodeC tagArrow [p1,p2]))
+    ce e | Just (Const z) <- constant e = return (Return z)
+    ce e | Just z <- constant e = return (gEval z)
+    ce e | Just z <- con e = return (Return z)
+    ce e | Just (a,_) <- from_unsafeCoerce e = ce a
+    ce ep@(EPrim (APrim (PrimPrim s) _) es _) = do 
+        fail $ "Unrecognized PrimPrim: " ++ show ep 
+        return $ App (toAtom $ 'b':s ) (args es)
+    ce (EPrim ap@(APrim (Func True fn as "void") _) (_:es) _) = do
+        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),tyUnit), primAPrim = ap }  
+        return $  Prim p (args es) :>>= unit :-> Return world__
+    ce (EPrim ap@(APrim (Func True fn as r) _) (_:es) rt) = do
+        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }  
+            ptv = Var v2 pt   
+            pt = Ty (toAtom r)
+        return $ Prim p (args es) :>>= ptv :-> Return (Tup [pworld__,ptv])
+    ce (EPrim ap@(APrim (Func False _ as r) _) es (ELit (LitCons tname [] _))) | RawType <- nameType tname = do
+        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }  
+        return $ Prim p (args es) 
+    ce (EPrim ap@(APrim (Peek pt') _) [_,addr] rt) = do
+        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup [Ty (toAtom "HsPtr")],pt), primAPrim = ap }  
+            ptv = Var v2 pt   
+            pt = Ty (toAtom pt')
+        return $  Prim p (args [addr]) :>>= ptv :-> Return (Tup [pworld__,ptv])
+    ce (EPrim ap@(APrim (Poke pt') _) [_,addr,val] _) = do
+        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup [Ty (toAtom "HsPtr"),pt],tyUnit), primAPrim = ap }  
+            pt = Ty (toAtom pt')
+        return $  Prim p (args [addr,val]) :>>= unit :-> Return world__
+    ce (EPrim aprim@(APrim (AddrOf s) _) [] (ELit (LitCons tname [] _))) | RawType <- nameType tname = do
+        let p = Primitive { primName = toAtom ('&':s), primRets = Nothing, primType = (tyUnit,ptype), primAPrim = aprim }
+            ptype = Ty $ toAtom (show tname) 
+        return $ Prim p [] 
+    ce (EPrim aprim@(APrim (CConst s t) _) [] (ELit (LitCons n [] _))) | RawType <- nameType n = do
+        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (tyUnit,ptype), primAPrim = aprim }
+            ptype = Ty $ toAtom t
+        return $ Prim p [] 
+--    ce (EPrim ap@(APrim (Peek pt') _) [_,addr] rt) = do
+--        (v,b,w) <- cpa addr
+--        (c,_) <- fromIORT rt
+--        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup [Ty (toAtom "HsPtr")],pt), primAPrim = ap }  
+--            ptv = Var v2 pt   
+--            pt = Ty (toAtom pt')
+--        return $ w :>>= b :-> Prim p [v] :>>= ptv :->  Store (NodeC (toAtom $ 'C':show c) [ptv]) :>>= p3 :-> retIO p3
+--    ce (EPrim ap@(APrim (Poke pt') _) [_,addr,val] _) = do
+--        (v,b,w) <- cpa addr
+--        (v',b',w') <- cpa val
+--        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup [Ty (toAtom "HsPtr"),pt],tyUnit), primAPrim = ap }  
+--            ptv = Var v2 pt   
+--            pt = Ty (toAtom pt')
+--        return $ w :>>= b :-> w' :>>= b' :-> Prim p [v,v'] :>>= unit :-> Return world__
+--    ce (EPrim ap@(APrim (Func True fn as "void") _) (_:es) _) = do
+--        es' <- mapM cpa es
+--        let fr = foldl (.) id [ (\e -> w :>>= b :-> e) | (_,b,w) <- es' ]
+--            p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),tyUnit), primAPrim = ap }  
+--        return $ fr ( Prim p [ x | (x,_,_) <- es' ] :>>= unit :-> Return world__)
+--    ce (EPrim ap@(APrim (Func True fn as r) _) (_:es) rt) = do
+--        es' <- mapM cpa es
+--        (c,rr) <- fromIORT rt
+--        let fr = foldl (.) id [ (\e -> w :>>= b :-> e) | (_,b,w) <- es' ]
+--            p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }  
+--            ptv = Var v2 pt   
+--            pt = Ty (toAtom r)
+--        return $ fr ( Prim p [ x | (x,_,_) <- es' ] :>>= ptv :-> Store (NodeC (toAtom $ 'C':show c) [ptv]) :>>= p3 :-> retIO p3)
+    --ce (EPrim aprim@(APrim (AddrOf s) _) [] t) | Just (c,ptype') <- lookupCType dataTable t = do
+    --    let cname = 'C':show c
+    --        ptype = Ty $ toAtom ptype'
+    --    let p = Primitive { primName = toAtom ('&':s), primRets = Nothing, primType = (tyUnit,ptype), primAPrim = aprim }
+    --    return $ Prim p [] :>>= Var v1 ptype :-> Return (NodeC (toAtom cname) [Var v1 ptype]) 
+    --ce (EPrim aprim@(APrim (CConst s _) _) [] t) |  Just (c,ptype') <- lookupCType dataTable t = do
+    --    let cname = 'C':show c
+    --        ptype = Ty $ toAtom ptype'
+    --    let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (tyUnit,ptype), primAPrim = aprim }
+    --    return $ Prim p [] :>>= Var v1 ptype :-> Return (NodeC (toAtom cname) [Var v1 ptype]) 
+    ce ee@(EPrim aprim@(APrim (CCast from to) _) [e] t)  = do 
+        let ptypeto' = Ty $ toAtom to
+            ptypefrom' = Ty $ toAtom from
+        let p = Primitive { primName = toAtom ("(" ++ to ++ ")"), primRets = Nothing, primType = (TyTup [ptypefrom'],ptypeto'), primAPrim = aprim }
+        return $  Prim p (args [e]) 
+    ce (EPrim ap@(APrim (Operator n as r) _) es (ELit (LitCons tname [] _))) | RawType <- nameType tname = do
+        let p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }  
+        return $ Prim p (args es) 
+        {-
+    ce (EPrim ap@(APrim (Operator n as r) _) es rt) = do
+        es' <- mapM cpa es
+        Just (c,rr) <- return $ lookupCType dataTable rt
+        True <- return $ rr == r
+        let fr = foldl (.) id [ (\e -> w :>>= b :-> e) | (_,b,w) <- es' ]
+            p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }  
+            ptv = Var v2 pt   
+            pt = Ty (toAtom r)
+        return $ fr ( Prim p [ x | (x,_,_) <- es' ] :>>= ptv :-> Return (NodeC (toAtom $ 'C':show c) [ptv]) )
+        {-
+    ce (EPrim ap@(APrim (Func False fn as r) _) es rt) = do
+        es' <- mapM cpa es
+        Just (c,rr) <- return $ lookupCType dataTable rt
+        let fr = foldl (.) id [ (\e -> w :>>= b :-> e) | (_,b,w) <- es' ]
+            p = Primitive { primName = Atom.fromString (pprint ap), primRets = Nothing, primType = (TyTup (map (Ty . toAtom) as),Ty (toAtom r)), primAPrim = ap }  
+            ptv = Var v2 pt   
+            pt = Ty (toAtom r)
+        return $ fr ( Prim p [ x | (x,_,_) <- es' ] :>>= ptv :-> Return (NodeC (toAtom $ 'C':show c) [ptv]) )
+        -}
+    ce ee@(EPrim aprim@(APrim (CCast from to) _) [e] t)  = do 
+        fd <- ce e 
+        Just (cfrom,ptypefrom) <- return $ lookupCType dataTable (typ e)
+        Just (cto,ptypeto) <- return $ lookupCType dataTable t
+        unless (ptypefrom == from && ptypeto == to) $ fail ("CCast no match: " ++ show ee)
+        let namecto = toAtom $ 'C':show cto
+            ptypeto' = Ty $ toAtom ptypeto
+            namecfrom = toAtom $ 'C':show cfrom
+            ptypefrom' = Ty $ toAtom ptypefrom
+            vfrom = Var v1 ptypefrom' 
+            vto = Var v2 ptypeto'
+        let p = Primitive { primName = toAtom ("(" ++ to ++ ")"), primRets = Nothing, primType = (TyTup [ptypefrom'],ptypeto'), primAPrim = aprim }
+        return $ fd :>>= NodeC namecfrom [vfrom] :-> Prim p [vfrom] :>>= vto :-> Return (NodeC namecto [vto]) 
+
+        x1 <- ce e1 
+        x2 <- ce e2 
+        (cons1,ctp1) <- lookupCType dataTable (typ e1)
+        (cons2,ctp2) <- lookupCType dataTable (typ e2)
+        (consr,ctpr) <- lookupCType dataTable t
+        True <- return $ t1 == ctp1
+        True <- return $ t2 == ctp2
+        True <- return $ rt == ctpr
+
+        let cname = 'C':show c
+        let p1 = Var v1 ptype
+            p2 = Var v2 ptype
+            p3 = Var v3 ptype
+            Just ptype' = Prelude.lookup (show c) allCTypes
+            node x = NodeC (toAtom cname) [x]
+            ptype = Ty $ toAtom ptype'
+        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (TyTup [ptype,ptype],ptype), primAPrim = aprim }
+        return $ x1 :>>= node p1 :-> x2 :>>= node p2 :-> Prim p [p1,p2] :>>= p3 :-> Return (node p3) 
+        -}
+    ce (ECase e _ [Alt (LitCons n xs _) wh] Nothing) | Just _ <- fromUnboxedNameTuple n = do
+        e <- ce e
+        wh <- ce wh
+        return $ e :>>= Tup (map toVal xs) :-> wh
+        
+    ce (ECase e b as d) | (ELit (LitCons n [] _)) <- typ e, RawType <- nameType n = do
+            let ty = Ty $ toAtom (show n)
+            v <- newPrimVar ty
+            e <- ce e 
+            as' <- mapM cp'' as
+            def <- createDef d (return (toVal b))
+            return $ 
+                e :>>= v :-> Case v (as' ++ def)
+        
+    ce (ECase e b as d) | any isJust  ls = ans where
+        ans = do
+            v <- newPrimVar ty
+            nv <- newNodeVar
+            e <- ce e 
+            as' <- mapM (cp' v cons) as
+            def <- createDef d (newPrimVar ty)
+            return $ 
+                e :>>= nv :-> 
+                Store nv :>>= toVal b :-> 
+                Return nv :>>= NodeC cons [v] :-> 
+                Case v (as' ++ def)
+        ls = map isBasic [ a | Alt a _ <- as]
+        Just (cons,ty) = msum ls
+    ce (ECase e b as d)  = do
+        v <- newNodeVar
+        e <- ce e 
+        as <- mapM cp as
+        def <- createDef d (newNodeVar)
+        return $ 
+            e :>>= v :->
+            Store v :>>= toVal b :-> 
+            Case v (as ++ def)
+    ce e = error $ "ce: " ++ show (funcName,e)
+    fromIORT e | ELit (LitCons tn [x,y] star) <- followAliases dataTable e, tn == tupNamet2, star == eStar, x == tWorld__ = lookupCType dataTable y
+    fromIORT e = fail $ "fromIORT: " ++ show e
+    retIO v = Return (NodeC (toAtom "CPrelude.(,)") [pworld__,v])
+    tupNamet2 = (nameTuple TypeConstructor 2)
+    cpa :: E -> IO (Val,Val,Exp) 
+    cpa e = do
+        v <- newVar 
+        (c,t) <- case lookupCType dataTable (typ e) of
+            Right x -> return x 
+            Left m -> fail (m <+> show e) 
+        let var = Var v (Ty $ toAtom t)
+        w <- ce e
+        return (var,NodeC (toAtom $ 'C':show c) [var],w) 
+
+    isBasic ( (LitInt _ t)) | Just (c,pt) <- lookupCType dataTable t = return (toAtom $ 'C':show c, Ty $ toAtom pt) 
+    --isBasic ( (LitInt _ (ELit (LitCons c [] _)))) | Just pt <- Prelude.lookup (show c) allCTypes = return (toAtom $ 'C':show c, Ty $ toAtom pt) 
+    --isBasic (PatLit (LitChar {})) = return tCharzh
+    isBasic e = fail $ "Not Basic: " ++ show e
+    createDef Nothing _ = return []
+    createDef (Just e) nnv = do
+        nv <- nnv 
+        x <- ce e
+        return [nv :-> x]
+--    cp (PatWildCard,ELam tvr e) = do
+--        x <- ce e
+--        v <- newNodeVar
+--        return (v :-> Store v :>>= toVal tvr :-> x)
+--    cp (PatWildCard,e) = do
+--        x <- ce e
+--        v <- newNodeVar
+--        w <- newNodePtrVar
+--        m <- newNodeVar
+--        return (v :-> Store v :>>= w :-> x :>>= m :-> gApply m w)
+    cp (Alt lc@(LitCons n es _) e) = do
+        --let (e',as') = fromLam e
+        x <- ce e
+        --es <- mapM (\_ -> newNodePtrVar) (drop (length as') es)
+        --x <- app x es
+        nn <- getName lc
+        return (NodeC nn (map toVal es) :-> x)
+    cp x = error $ "cp: " ++ show (funcName,x)
+    cp'' (Alt (LitInt i (ELit (LitCons nn [] _))) e) = do
+        x <- ce e
+        return (Lit i (Ty $ toAtom (show nn)) :-> x)
+        
+    cp' nv cons p = f p where
+        f (Alt l@(LitInt i _) e) = do
+            x <- ce e
+            --z <- const $ ELit l 
+            (_,tp) <- isBasic l
+            z <- return $ Lit i tp
+            return (z :-> x)
+--        f (PatLit l@(LitChar i),e) = do
+--            x <- ce e
+--            --z <- const $ ELit l 
+--            z <- return $ Lit (ord i) tCharzh
+--            return (z :-> x)
+--        f (PatWildCard,ELam (TVr Nothing _)  e) = do
+--            x <- ce e
+--            nv <- newPrimVar (Ty cons)
+--            return (nv :-> x)
+--        f (PatWildCard,ELam tvr e) = do
+--            x <- ce e
+--            nv' <- newPrimVar (Ty cons)
+--            return (nv' :-> Store (NodeC cons [nv]) :>>= toVal tvr :-> x)
+--        f (PatWildCard,e) = do
+--            x <- ce e
+--            w <- newNodePtrVar
+--            m <- newNodeVar
+--            nv' <- newPrimVar (Ty cons)
+--            return (nv' :-> Store (NodeC cons [nv]) :>>= w :-> x :>>= m :-> gApply m w)
+
+    getName x = getName' dataTable x
+{-
+    getName v@(LitCons n es _) 
+        | conAlias cons = error $ "Alias still exists: " ++ show v 
+        | length es == nargs  = do
+            return cn
+        | nameType n == TypeConstructor && length es < nargs = do
+            return ((partialTag cn (nargs - length es)))
+        where
+        cn = convertName n
+        cons = runIdentity $ getConstructor n dataTable 
+        nargs = length (conSlots cons)
+-}
+{-
+    cp (PatLit (LitCons n es _),e) = do
+        x <- ce e
+        es <- mapM (\_ -> newNodePtrVar) es
+        x <- app x es
+        return (NodeC (convertName n) es :-> x)
+-}        
+    
+    app e [] = return e
+    app e (a:as) = do
+        v <- newNodeVar
+        app (e :>>= v :-> gApply v a) as
+    app' e [] = return $ Return e
+    app' (Const (NodeC t cs)) (a:as) | tagIsPartialAp t = do
+        let ('P':rs') = fromAtom t
+            (n','_':rs) = span isDigit rs'
+            n = (read n' :: Int)
+            lazy = do 
+                mtick "Grin.FromE.lazy-app-const"
+                app' (Const (NodeC (partialTag (toAtom $ 'f':rs) (n - 1)) (cs ++ [a]))) as 
+        case a of 
+            Const {} -> lazy 
+            Lit {} -> lazy 
+            Var (V n) _ | n < 0 -> lazy 
+            _ -> do
+                mtick "Grin.FromE.lazy-app-store"
+                tpv <- newNodePtrVar
+                x <- app' tpv as
+                return $ Store  (NodeC (partialTag (toAtom $ 'f':rs) (n - 1)) (cs ++ [a])) :>>= tpv :-> x
+    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  
+            args = [Var v (TyPtr TyNode) | v <- [v1..] | _ <- (undefined:as)]
+            s = Store (NodeC t (e:as))
+        d <- app (gEval p1) (tail args)
+        addNewFunction (tl,Tup (args) :-> d)
+        --modifyIORef (funcBaps cenv) ((tl,Tup (args) :-> d):)
+        --let addt (TyEnv mp) =  TyEnv $ Map.insert tl (replicate (length args) (TyPtr TyNode),TyNode) mp
+        --modifyIORef (tyEnv cenv) addt
+        return s
+    addNewFunction tl@(n,Tup args :-> _) = do
+        modifyIORef (funcBaps cenv) (tl:)
+        tenv <- readIORef (tyEnv cenv)
+        args' <- mapM (typecheck tenv) args
+        let addt (TyEnv mp) =  TyEnv $ Map.insert n (args',TyNode) mp
+        modifyIORef (tyEnv cenv) addt
+    
+    {-
+    app' e (a:as) = do
+        v <- newNodePtrVar
+        let s = Store (NodeC tagApply [e,a])
+        r <- app' v as
+        return (s :>>= v :-> r) 
+    -}
+
+    --cc e | Just c <- const e = do
+    --    return (Return (Const c))
+    --cc (EPi (TVr 0 a) b) = do
+    --    a' <- cc a
+    --    b' <- cc b 
+    --    p1 <- newNodePtrVar
+    --    p2 <- newNodePtrVar
+    --    return (a' :>>= p1 :-> b' :>>= p2 :-> Store (NodeC tagArrow [p1,p2]))
+    cc e | Just z <- constant e = return (Return z)
+    cc e | Just z <- con e = do
+        return (Store z)
+    cc (ELetRec ds e) = cc e >>= \e -> doLet ds e
+    cc e |  (v,as) <- fromAp e, EVar v <- dropCoerce v = do
+        as <- return $ args as 
+        case Map.lookup (tvrNum 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) x)
+                    nv <- newNodePtrVar 
+                    z <- app' nv y
+                    return $ s :>>= nv :-> z
+                    --fail "thinking still..."
+                | otherwise -> do
+                    let pt = partialTag v (length as' - length as)
+                    return $ Store (NodeC pt as)
+            Nothing 
+                | [] <- as -> return $ Return (toVal v)
+                | otherwise  -> app' (toVal v) as
+    cc e | Just (x,_) <- from_unsafeCoerce e = cc x
+--    cc e | Just (x,_) <- from_integralCast e = cc x
+--    cc (EPrim aprim@(APrim (PrimPrim s) _) es pt) = do
+--        V vn <- newVar
+--        te <- readIORef (tyEnv cenv) 
+--        let fn = toAtom ('b':s ++ "_" ++ show vn)
+--            fn' = toAtom ('B':s ++ "_" ++ show vn)
+--        case findArgsType te fn of
+--            Just _ -> return $ Store $ NodeC fn' (args es)
+--            Nothing -> do
+--                let es' = args es
+--                ts <- mapM (typecheck te) es'
+--                let nvs = [ Var v t | t <- ts | v <- [v2,V 4..] ]
+--                x <- ce (EPrim aprim [ EVar (TVr v t) | t <- map typ es | v <- [2,4..]] pt)
+--                addNewFunction (fn,Tup nvs :-> x)
+--                return $ Store $ NodeC fn' es'
+    cc (EPrim aprim@(APrim prim _) es pt) = do
+        V vn <- newVar
+        te <- readIORef (tyEnv cenv) 
+        let s = pprint prim
+            fn' = toAtom ('B':s ++ "_" ++ show vn)
+            fn = toAtom ('b':s ++ "_" ++ show vn)
+        case findArgsType te fn of
+            Just _ -> return $ Store $ NodeC fn' (args es)
+            Nothing -> do
+                let es' = args es
+                ts <- mapM (typecheck te) es'
+                let nvs = [ Var v t | t <- ts | v <- [v2,V 4..] ]
+                x <- ce (EPrim aprim [ EVar (tvr { tvrIdent = v, tvrType =  t}) | t <- map typ es | v <- [2,4..]] pt)
+                addNewFunction (fn,Tup nvs :-> x)
+                return $ Store $ NodeC fn' es'
+    --cc (EPrim (APrim (PrimPrim s) _) es _) = do 
+    --    return $ Store $ NodeC (toAtom $ "B" ++ s ) (args es)
+    cc e = error $ "cc: " ++ show e
+    doLet ds e = f (decomposeDefns ds) e where 
+        f [] x = return x
+        f (Left (t,e):ds) x = do
+            e <- cc e 
+            v <- f ds x
+            return $ e :>>= toVal t :-> v
+        f (Right bs:ds) x = do
+            let g (tvr,_) y = (Store (NodeC (toAtom "@hole") []) :>>= toVal tvr :-> y)
+                u (tvr,e) = do
+                    v <- newNodePtrVar 
+                    v' <- newNodeVar 
+                    e <- cc e
+                    return $ doUpdate (toVal tvr) e
+                    
+                    --return (e :>>= v :-> 
+                    --        Fetch v :>>= v' :-> 
+                    --        Update (toVal tvr) v')
+            xs <- mapM u bs
+            v <- f ds x
+            let r = (foldr (\a b -> a :>>= unit :-> b) v xs)
+            return $ foldr g r bs
+
+            --fail "can't handle recursion just yet."
+    -- This avoids a blind update on recursive thunks
+    doUpdate vr (Store n) = Update vr n 
+    doUpdate vr (x :>>= v :-> e) = x :>>= v :-> doUpdate vr e
+    doUpdate vr x = error $ "doUpdate: " ++ show x
+    args es = map f es where
+        --f x | Just z <- caforconst x =  z
+        f x | Just z <- constant x =  z
+        f (EVar tvr) = toVal tvr
+        f e | Just (x,_) <- from_unsafeCoerce e = f x
+--        f e | Just (x,_) <- from_integralCast e = f x
+        f x = error $ "invalid argument: " ++ show x
+
+    -- Takes an E and returns something constant of type (TyPtr TyNode) 
+    constant :: Monad m =>  E -> m Val 
+    constant (EVar tvr) | Just c <- Map.lookup (tvrNum tvr) (ccafMap cenv) = return c 
+                        | Just (v,as,_) <- Map.lookup (tvrNum tvr) (scMap cenv)  
+                         , t <- partialTag v (length as)  = case tagIsWHNF t of
+                            True -> return $ Const $ NodeC t []
+                            False -> return $ Var (V $ - atomIndex t) (TyPtr TyNode)  
+                            --case constant e of
+                            --    Just x -> return x
+                            --    Nothing -> return $ Var (V $ - atomIndex t) (TyPtr TyNode) 
+    constant (ELit (LitInt i (ELit (LitCons n [] (ESort 0))))) | RawType <- nameType n = return $ Lit i (Ty $ toAtom (show n))
+    constant (ELit (LitInt i (ELit (LitCons n [] (ESort 0))))) | Just pt <- Prelude.lookup (show n) allCTypes = (return $ Const (NodeC (toAtom $ 'C':show n) [(Lit i (Ty (toAtom pt)))]))
+    constant (ELit lc@(LitCons n es _)) | Just es <- mapM constant es, Just nn <- getName lc = (return $ Const (NodeC nn es))
+    constant (EPi (TVr { tvrIdent = 0, tvrType = a}) b) | Just a <- constant a, Just b <- constant b = return $ Const $ NodeC tagArrow [a,b]
+    constant e | Just (a,_) <- from_unsafeCoerce e = constant a
+--    constant e | Just (a,_) <- from_integralCast e = constant a
+    constant _ = fail "not a constant term"
+
+    caforconst e = constant e
+    
+    {-
+    caforconst :: Monad m =>  E -> m Val 
+    caforconst (EVar tvr)  | Just (v,as,_) <- Map.lookup (tvrNum tvr) (scMap cenv)  
+                         , t <- partialTag v (length as)  = case tagIsWHNF t of
+                            True -> return $ Const $ NodeC t []
+                            False -> return $ Var (V $ - atomIndex t) (TyPtr TyNode) 
+    caforconst e = liftM Const $ const e
+    
+    const :: Monad m => E -> m Val  --needed for polymorphic recursion
+    const (EVar tvr)  | Just (v,as,_) <- Map.lookup (tvrNum tvr) (scMap cenv)  
+                         , t <- partialTag v (length as)  = case tagIsWHNF t of
+                            True -> return $ NodeC t []
+                            False -> fail "const: CAF"
+    --const (ELit (LitInt i t)) | t == tChar = (return (NodeC (toAtom "CChar") [(Lit ( fromIntegral i) tCharzh)]))
+    --const (ELit (LitInt i t))   = (return (NodeC (toAtom "CInt") [(Lit (fromIntegral i) tIntzh)]))
+    const (ELit (LitInt i (ELit (LitCons n [] (ESort 0))))) | Just pt <- Prelude.lookup (show n) allCTypes = (return (NodeC (toAtom $ 'C':show n) [(Lit (fromIntegral i) (Ty (toAtom pt)))]))
+    const (ELit lc@(LitCons n es _)) | Just es <- mapM const es, Just nn <- getName lc = (return (NodeC nn (map Const es)))
+    const (EPi (TVr 0 a) b) | Just a <- const a, Just b <- const b = return $ NodeC tagArrow [Const a,Const b]
+    --const e@(EPi {}) | (ELit (LitCons n as' t),as) <- fromPi e, as == [ v | EVar v <- as'] = const (ELit (LitCons n [] undefined)) 
+    const _ = fail "not a constant term"
+      -}
+    con :: Monad m => E -> m Val
+    --con e | Just z <- const e = return z
+    --con e | Just (Const z) <- constant e = return z
+    con (EPi (TVr {tvrIdent =  0, tvrType = x}) y) = do
+        return $  NodeC tagArrow (args [x,y])
+    con v@(ELit (LitCons n es _)) 
+        | conAlias cons = error $ "Alias still exists: " ++ show v 
+        | length es == nargs  = do
+            return ((NodeC cn (args es)))
+        | nameType n == TypeConstructor && length es < nargs = do
+            return (NodeC (partialTag cn (nargs - length es)) $ args es)
+        where
+        cn = convertName n
+        Just cons = getConstructor n dataTable 
+        nargs = length (conSlots cons)
+        
+    con _ = fail "not constructor"
+
+    
+    scInfo tvr | Just n <- Map.lookup (tvrNum tvr) (scMap cenv) = return n 
+    scInfo tvr = fail $ "not a supercombinator:" <+> show tvr 
+    --newVar' = fmap (\x -> Var x TyNode) newVar 
+    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 <- readIORef (counter cenv)
+        writeIORef (counter cenv) $! (i + 2)
+        return $! V i
+
+    --ce (EPi (TVr Nothing x) y) = do
+    --    return $ Return $ NodeC (toAtom "T->") (args [x,y])
+    --ce (ELit (LitCons n es _)) = do
+    --    return (Return (NodeC (convertName n) (args es)))
+--        f (EVar tvr) 
+--            | Just (v,as,_) <- Map.lookup (tvrNum tvr) (scMap cenv) = 
+--                    let pt = partialTag v (length as) in  
+--                      (Const $ NodeC pt [])
+--            | otherwise  = toVal tvr
+    --cc e@EPi {} = do
+    --   v <- newNodeVar
+    --    x <- ce e
+    --    return (x :>>= (v,Store v))
+ 
+--    ce e | Just (a,_) <- from_integralCast e = ce a
+    --ce (EPrim "seq" [a,b] _) = do 
+    --    a <- ce a
+    --    b <- ce b 
+    --    return $ a :>>= n0 :-> b
+--    ce (EPrim aprim@(APrim (PrimPrim s) _) [] t) | "prim_const." `isPrefixOf` s, Just (c,ptype') <- lookupCType dataTable t = do
+--        let cname = 'C':show c
+--        --let Just ptype' = Prelude.lookup (show c) allCTypes
+--            ptype = Ty $ toAtom ptype'
+--        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (tyUnit,ptype), primAPrim = aprim }
+--        return $ Prim p [] :>>= Var v1 ptype :-> Return (NodeC (toAtom cname) [Var v1 ptype]) 
+--    ce (EPrim aprim@(APrim (PrimPrim s) _) [e] (ELit (LitCons c [] (ESort 0)))) | "prim_op_aa." `isPrefixOf` s = do
+--        x <- ce e 
+--        let cname = 'C':show c
+--        let p1 = Var v1 ptype
+--            p2 = Var v2 ptype
+--            node x = NodeC (toAtom cname) [x]
+--            Just ptype' = Prelude.lookup (show c) allCTypes
+--            ptype = Ty $ toAtom ptype'
+--        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (TyTup [ptype],ptype), primAPrim = aprim }
+--        return $ x :>>= node p1 :-> Prim p [p1] :>>= p2 :-> Return (node p2) 
+--    ce (EPrim aprim@(APrim (PrimPrim s) _) [e1,e2] (ELit (LitCons c [] (ESort 0)))) | "prim_op_aaa." `isPrefixOf` s = do
+--        x1 <- ce e1 
+--        x2 <- ce e2 
+--        let cname = 'C':show c
+--        let p1 = Var v1 ptype
+--            p2 = Var v2 ptype
+--            p3 = Var v3 ptype
+--            Just ptype' = Prelude.lookup (show c) allCTypes
+--            node x = NodeC (toAtom cname) [x]
+--            ptype = Ty $ toAtom ptype'
+--        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (TyTup [ptype,ptype],ptype), primAPrim = aprim }
+--        return $ x1 :>>= node p1 :-> x2 :>>= node p2 :-> Prim p [p1,p2] :>>= p3 :-> Return (node p3) 
+--    ce (EPrim aprim@(APrim (PrimPrim s) _) [e1,e2] (ELit (LitCons c [] (ESort 0)))) | "prim_op_aaa." `isPrefixOf` s = do
+--        x1 <- ce e1 
+--        x2 <- ce e2 
+--        let cname = 'C':show c
+--        let p1 = Var v1 ptype
+--            p2 = Var v2 ptype
+--            p3 = Var v3 ptype
+--            Just ptype' = Prelude.lookup (show c) allCTypes
+--            node x = NodeC (toAtom cname) [x]
+--            ptype = Ty $ toAtom ptype'
+--        let p = Primitive { primName = toAtom s, primRets = Nothing, primType = (TyTup [ptype,ptype],ptype), primAPrim = aprim }
+--        return $ x1 :>>= node p1 :-> x2 :>>= node p2 :-> Prim p [p1,p2] :>>= p3 :-> Return (node p3) 
+--    ce (EPrim aprim@(APrim (PrimPrim s) _) [e1,e2] tBool) | "prim_op_aaB." `isPrefixOf` s = do
+--        x1 <- ce e1 
+--        x2 <- ce e2 
+--        let cname = 'C':show c
+--            p1 = Var v1 ptype
+--            p2 = Var v2 ptype
+--            p3 = Var v3 intT   
+--            (ELit (LitCons c [] (ESort 0))) = followAliases dataTable (typ e1)
+--            intT =   (Ty (toAtom "int"))
+--            Just ptype' = Prelude.lookup (show c) allCTypes
+--            node x = NodeC (toAtom cname) [x]
+--            ptype = Ty $ toAtom ptype'
+--            p = Primitive { primName = toAtom s, primRets = Nothing, primType = (TyTup [ptype,ptype],intT), primAPrim = aprim }
+--        return $ x1 :>>= node p1 :-> x2 :>>= node p2 :-> Prim p [p1,p2] :>>= p3 :-> Case p3 [Lit 0 intT :-> Return vFalse, Var v0 intT :-> Return vTrue]
addfile ./Grin/Grin.hs
hunk ./Grin/Grin.hs 1
+{-# OPTIONS -funbox-strict-fields #-}
+
+module Grin.Grin(
+    tagIsWHNF,
+    tagIsPartialAp,
+    tagIsTag,
+    tagIsSuspFunction,
+    tagIsFunction,
+    tagToFunction,
+    tagFlipFunction,
+    valIsNF,
+    gApply,
+    partialTag,
+    gEval,
+    tagApply,
+    tagArrow,
+    tagHole,
+    Exp(..),
+    Ty(..),
+    Tag,
+    TyEnv(..),
+    Val(..),
+    v0,v1,v2,v3,
+    p0,p1,p2,p3,
+    n0,n1,n2,n3,
+    Var(..),
+    createEval',
+    sequenceG_,
+    funcEval,
+    funcFetch,
+    funcApply,
+    funcInitCafs,
+    Grin(..),
+    HasType(..),
+    Primitive(..),
+    Builtin,
+    Props(..),
+    Lam(..),
+    unit,
+    tyUnit,
+    funcMain,
+    findArgsType, findArgs) where
+
+import Atom
+import Boolean.Algebra
+import Char
+import Control.Monad.Identity
+import C.Prims
+import Data.IORef
+import Data.Monoid
+import DDataUtil()
+import Doc.DocLike
+import FreeVars
+import GenUtil
+import List(isPrefixOf)
+import Number
+import Prelude hiding((&&),(||),not,and,or,any,all)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import VConsts
+
+-- 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? )
+
+
+newtype TyEnv = TyEnv (Map.Map Atom ([Ty],Ty))
+    deriving(Monoid)
+
+
+tagApply = toAtom "Bap"
+tagArrow = toAtom "TPrelude.->"
+tagHole = toAtom "@hole"
+funcApply = toAtom "@apply"
+funcEval = toAtom "@eval"
+funcFetch = toAtom "@fetch"
+funcInitCafs = toAtom "@initcafs"
+funcMain = toAtom "@main"
+
+gEval x = App funcEval [x]
+gApply x y = App funcApply [x,y]
+
+
+instance TypeNames Ty where
+    tIntzh = Ty (toAtom "int")
+    tCharzh = Ty (toAtom "uint32_t")
+    tStar = Ty (toAtom "*")
+
+data Ty =
+    TyTag           -- ^ a lone tag
+    | TyPtr Ty      -- ^ pointer to a heap location which contains its argument
+    | TyNode        -- ^ a whole tagged node
+    | Ty Atom       -- ^ a basic type
+    | TyTup [Ty]    -- ^ unboxed list of values
+    | TyUnknown     -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation
+    deriving(Eq,Ord)
+
+instance Show Ty where
+    show TyTag = "T"
+    show (Ty a) = fromAtom a
+    show TyNode = "N"
+    show (TyPtr t) = '&':show t
+    show (TyTup []) = "()"
+    show (TyTup ts) =  show ts
+    show TyUnknown = "?"
+
+
+type Tag = Atom
+
+newtype Var = V Int
+    deriving(Eq,Ord,Enum)
+
+instance Show Var where
+    showsPrec _ (V n) xs = 'v':shows n xs
+
+a @>> b = a :>>= (unit :-> b)
+sequenceG_ [] = Return unit
+sequenceG_ (x:xs) = foldl (@>>) x xs
+
+
+
+
+infixr 1  :->, :>>=
+
+
+tyUnit = TyTup []
+unit = Tup []
+
+data Lam = Val :-> Exp
+    deriving(Eq,Ord,Show)
+
+data Exp =
+     Exp :>>= !Lam
+    | App Atom [Val]  -- ^ this handles applications of functions and builtins
+    | Prim Primitive [Val]
+    | Case Val [Lam]
+    | Return { expValue :: Val }
+    | Store { expValue :: Val }
+    | Fetch { expAddress :: Val }
+    | Update { expAddress :: Val, expValue :: Val }
+    | Error String Ty -- ^ abort with an error message, non recoverably.
+    | Cast Val Ty     -- ^ reinterpret Val as a different type, also used to box\/unbox lifted types
+    deriving(Eq,Show,Ord)
+
+data Val =
+    NodeC !Tag [Val]
+    | NodeV !Var [Val]
+    | Tag !Tag
+    | Const Val         -- ^ pointer to constant data, only Lit, Tag, and NodeC may be children
+    | Lit !Number Ty
+    | Var !Var Ty
+    | Tup [Val]
+    | ValPrim APrim
+    | Addr {-# UNPACK #-} !(IORef Val)  -- used only in interpreter
+    deriving(Eq,Show,Ord)
+
+
+instance Show (IORef a) where
+    show _ = "IORef"
+instance Ord (IORef a) where
+    compare a b = EQ
+
+
+
+data Grin = Grin {
+    grinTypeEnv :: TyEnv,
+    grinFunctions :: [(Atom,Lam)],
+--    grinPrimitives :: [(Primitive,Builtin)],
+    grinCafs :: [(Var,Val)]
+}
+
+data Flag = No | Maybe | Yes
+    deriving(Eq,Ord,Enum,Show)
+
+
+instance Monoid Flag where
+    mempty = No
+    mappend a b = max a b
+    mconcat xs = maximum xs
+
+
+instance SemiBooleanAlgebra Flag where
+    (&&) = max
+    Yes || Yes = Yes
+    No || No = No
+    _ || _ = Maybe
+
+
+data Primitive = Primitive {
+    primName :: Atom,
+    primRets :: Maybe [Atom],
+    primType :: (Ty,Ty),
+    primAPrim :: APrim
+    --primProps :: Props
+    --primCallingConvention :: (),
+    } deriving(Show)
+
+instance Eq Primitive where
+    a == b = primName a == primName b
+    a /= b = primName a /= primName b
+
+instance Ord Primitive where
+    compare a b = compare (primName a) (primName b)
+
+data Props = Props {
+    hasSideEffects :: Flag,  -- ^ has side effects
+    causesError    :: Flag,  -- ^ contains Error or aborting primitive
+    allocsMem      :: Flag   -- ^ calls store (does not count as side effect)
+    } deriving(Show)
+
+instance Monoid Props where
+    mempty = Props mempty mempty mempty
+    Props x y z `mappend` Props a b c = Props (mappend x a) (mappend y b) (mappend z c)
+instance SemiBooleanAlgebra Props where
+    Props x y z && Props a b c = Props ((&&) x a) ((&&) y b) ((&&) z c)
+    Props x y z || Props a b c = Props ((||) x a) ((||) y b) ((||) z c)
+
+
+propsMaybe = Props { hasSideEffects = Maybe, causesError = Maybe, allocsMem = Maybe }
+
+props :: Exp -> Props
+props (x :>>= (_ :-> y)) = props x && props y
+props (Case _ xs) = or1 [ props x | _ :-> x <- xs ]
+props Return {} = mempty
+props Store {} = mempty { allocsMem = Yes }
+props Fetch {} = mempty
+props Update {} = mempty { hasSideEffects = Yes }
+props Error {} = mempty { causesError = Yes }
+props Cast {} = mempty
+props _ = error "props"
+
+
+type Builtin = [Val] -> IO Val
+
+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)
+
+
+
+
+
+
+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
+    | t == funcMain = return t
+    | t == funcInitCafs = return 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
+    | t == funcMain = True
+    | t == funcInitCafs = True
+    | '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 (Tup xs) = all valIsNF xs
+valIsNF (Tag _) = True
+--valIsNF Unit = True
+valIsNF Const {} = True
+valIsNF Lit {} = True
+valIsNF _ = False
+
+
+
+-- create an eval suitable for inlining.
+createEval' :: Bool -> TyEnv -> [Tag] -> Lam
+createEval' shared  te ts
+
+    | null cs = p1 :-> Error "Empty Eval" TyNode
+    | all tagIsWHNF [ t | t <- ts , tagIsTag t] = p1 :-> Fetch p1
+    | otherwise = p1 :->
+        Fetch p1 :>>= n2 :->
+        Case n2 cs :>>= n3 :->
+        Update p1 n3 :>>= unit :->
+        Return n3
+    where
+    cs = [f t | t <- ts, tagIsTag t ]
+    g t vs
+        | tagIsWHNF t = Return n2
+        | '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
+        | otherwise = App (toAtom $ n) vs
+
+
+{-
+createEval :: TyEnv -> [Tag] -> Exp
+createEval  te ts
+    | null cs = Error ("Empty Eval:" ++ show ts) TyNode
+    | otherwise =
+        Fetch p1 :>>= n2 :->
+        Case n2 cs :>>= n3 :->
+        Update p1 n3 :>>= unit :->
+        Return n3
+    where
+    cs = [f t | t <- ts, tagIsTag t ]
+    g t vs
+        | tagIsWHNF t = Return n2
+        | 'F':fn <- fromAtom t  = App (toAtom $ 'f':fn) vs -- :>>= n3 :-> Update p1 n3 :>>= unit :-> Return n3
+        | 'B':fn <- fromAtom t  = App (toAtom $ '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]
+        -}
+
+
+---------
+-- Look up stuff in the typing environment.
+---------
+
+findArgsType (TyEnv m) a | Just x <-  Map.lookup a m = return x
+findArgsType (TyEnv m) a | ('F':rs) <- fromAtom a = case Map.lookup (toAtom ('f':rs)) m of
+    Just x -> return x
+    Nothing -> fail $ "findArgsType: " ++ show a
+findArgsType (TyEnv m) a | ('B':rs) <- fromAtom a = case Map.lookup (toAtom ('b':rs)) m of
+    Just x -> return x
+    Nothing -> fail $ "findArgsType: " ++ show a
+findArgsType (TyEnv m) a | ('P':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case Map.lookup (toAtom ('f':rs)) m of
+    Just (ts,n) -> return (take (length ts - read ns) ts,n)
+    Nothing -> fail $ "findArgsType: " ++ show a
+findArgsType (TyEnv m) a | ('Y':rs) <- fromAtom a, (ns,'_':rs) <- span isDigit rs  = case Map.lookup (toAtom ('T':rs)) m of
+    Just (ts,n) -> return (take (length ts - read ns) ts,n)
+    Nothing -> fail $ "findArgsType: " ++ show a
+--findArgsType _ a | a == tagApply = return ([TyPtr TyNode,TyPtr TyNode],TyNode)
+findArgsType _ a | a == toAtom "TAbsurd#" = return ([],TyNode)
+findArgsType _ a | a == funcEval = return ([TyPtr TyNode],TyNode)
+findArgsType _ a | a == funcApply = return ([TyNode, TyPtr TyNode],TyNode)
+findArgsType _ a | a == funcMain = return ([],tyUnit)
+findArgsType _ a | a == tagHole = return ([],TyNode)
+findArgsType _ a | "@hole" `isPrefixOf` fromAtom a  = return ([],TyNode)
+findArgsType _ a =  fail $ "findArgsType: " ++ show a
+
+findType (TyEnv m) a = case Map.lookup a m of
+    Nothing -> fail $ "findType: " ++ show a
+    Just (_,x) -> return x
+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 ConNames Val where
+    vTrue = NodeC (toAtom "CPrelude.True") []
+    vFalse = NodeC (toAtom "CPrelude.False") []
+    vUnit =  NodeC (toAtom "CPrelude.()") []
+    vOrdering x = NodeC (toAtom $ "CPrelude." ++ show x) []
+
+-- typechecking
+class HasType a where
+    typecheck :: Monad m => TyEnv -> a -> m Ty
+    tc :: Monad m => TyEnv -> a -> m Ty
+    tc = typecheck
+
+
+instance HasType a => HasType [a] where
+    typecheck _ [] = fail "empty list"
+    typecheck te xs = do
+        ts <- mapM (typecheck te) xs
+        foldl1M_ (same "list") ts
+        return (head ts)
+    tc _ [] = fail "empty list"
+    tc te (x:_) = tc te x
+
+
+same _ t1 t2 | t1 == t2 = return t1
+same msg t1 t2 = fail $ "Types not the same:" <+> msg <+> tshow t1 <+> tshow t2
+
+typLam te (x :-> y) = do
+    x <- typecheck te x
+    y <- typecheck te y
+    return (x,y)
+
+
+
+instance HasType Exp where
+    typecheck te (e :>>= (v :-> e2)) = do
+        t1 <- typecheck te e
+        t2 <- typecheck te v
+        same (":>>=" <+> show e <+> show v) t1 t2
+        typecheck te e2
+    typecheck te n@(Prim p as) = do
+        let (TyTup as',t') = primType p
+        as'' <- mapM (typecheck te) as
+        if as'' == as' then return t' else
+            fail $ "Prim: arguments do not match " ++ show n
+    typecheck te a@(App fn as) = do
+        (as',t') <- findArgsType te fn
+        as'' <- mapM (typecheck te) as
+        if as'' == as' then return t' else
+            fail $ "App: arguments do not match: " ++ show a
+    typecheck te (Store v) = do
+        t <- typecheck te v
+        return (TyPtr t)
+    typecheck te (Return v) = do
+        typecheck te v
+    typecheck te (Fetch v) = do
+        (TyPtr t) <- typecheck te v
+        return t
+    typecheck te (Error _ t) = return t
+    typecheck te e@(Update w v) = do
+        (TyPtr t) <- typecheck te w
+        t' <- typecheck te v
+        same (show e) t t'
+        return tyUnit
+    typecheck _ (Case _ []) = fail "empty case"
+    typecheck te (Case v as) = do
+        tv <- typecheck te v
+        (ps,es) <- liftM unzip $ mapM (typLam te) as
+        foldl1M_ (same "case pat") (tv:ps)
+        foldl1M (same $ "case exp: " ++ show (map head $ sortGroupUnder fst (zip es as)) ) (es)
+    typecheck te (Cast _ t) = return t
+    tc te (_ :>>= (_ :-> e)) = tc te e
+    tc te e = typecheck te e
+
+instance HasType Val where
+    typecheck _ (Tag _) = return TyTag
+--    typecheck _ Unit = return tyUnit
+    typecheck _ (Var _ t) = return t
+    typecheck _ (Lit _ t) = return t
+    typecheck _ (NodeV {}) = return TyNode
+    typecheck te (Tup xs) = do
+        xs <- mapM (typecheck te) xs
+        return $ TyTup xs
+    typecheck x (Const t) = do
+        v <- typecheck x t
+        return (TyPtr v)
+--    typecheck _ (NodeC {}) = return TyNode
+    typecheck _ (Addr _) = return $ TyPtr (error "typecheck: Addr")
+    typecheck _ (ValPrim _) = error "ValPrim"
+    typecheck te n@(NodeC tg as) = do
+        (as',_) <- findArgsType te tg
+        as'' <- mapM (typecheck te) as
+        if as'' == as' then return TyNode else
+            fail $ "NodeC: arguments do not match " ++ show n ++ show (as'',as')
+
+instance FreeVars Lam (Set.Set Var) 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 (NodeV _ xs) = freeVars xs
+    freeVars (Const v) = freeVars v
+    freeVars (Var v _) = Set.singleton v
+    freeVars (Tup vs) = freeVars vs
+    freeVars _ = Set.empty
+
+
+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 (Cast x _) = freeVars x
+    freeVars (Prim _ x) = freeVars x
+    freeVars Error {} = Set.empty
+
+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 (NodeV _ xs) = freeVars xs
+    freeVars (Tup xs) = freeVars xs
+    freeVars (Tag t) = Set.singleton t
+    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 (Cast x _) = freeVars x
+    freeVars (Prim _ x) = freeVars x
+    freeVars Error {} = Set.empty
+
+
+
addfile ./Grin/Grin.hs-boot
hunk ./Grin/Grin.hs-boot 1
+module Grin.Grin where
+
+
+data Exp
+data Grin
+data Val
+data Lam
addfile ./Grin/HashConst.hs
hunk ./Grin/HashConst.hs 1
+module Grin.HashConst where
+
+import Grin.Grin
+import Atom
+import Control.Monad.State
+import qualified Data.Map as Map
+import GraphUtil
+
+-- 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 
+
+{-# INLINE newConst #-}
+{-# INLINE newConst' #-}
+newConst :: MonadState HcHash m => Val -> m (Bool,Int) 
+newConst n = newConst' False n
+
+newConst' :: MonadState HcHash m => Bool -> Val -> m (Bool,Int) 
+newConst' fuzzy n = f n where
+    f (NodeC t vs) = do
+        let g (Lit i ty) 
+                | fuzzy = return $ Left (Lit 0 ty)
+                | otherwise = return $ Left (Lit i ty)
+            g (Tag t)  
+                | fuzzy = return $ Left (Tag tagHole)  
+                | otherwise = return $ Left (Tag t)  
+            g x@(Var (V n) _) | n < 0  = return $ Left x
+            g (Const n) = 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) 
+
+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
+
addfile ./Grin/Interpret.hs
hunk ./Grin/Interpret.hs 1
+module Grin.Interpret(evaluate) where
+
+import Data.IORef
+import Grin.Grin
+import Atom
+import Control.Monad.Identity
+import qualified FlagDump as FD
+import Options
+import Data.Monoid
+import qualified Stats
+import Data.Map as Map hiding(map)
+import E.Pretty(render)
+import Grin.Show
+import CharIO
+import Char
+import VConsts
+--import Grin.Primitives
+import Doc.Pretty
+import Doc.DocLike
+import E.Pretty
+import GenUtil hiding(putErrLn,putErr)
+
+builtins = []
+--createCafMap as = f vars [] >>= return . Map.fromList  where
+--    f [] xs = return xs
+--    f ((x,y):xs) ys = newIORef (NodeC y []) >>= \y -> f xs ((x,Addr y):ys) 
+--    vars = [ ((V $ - atomIndex tag) ,tag) | (x,[],_) <- as, x /= funcInitCafs, let tag = partialTag x 0]
+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 [])
+    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) = do
+        wdump FD.Steps $ do
+            putErrLn $ render (prettyExp mempty $ App a xs')
+        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')
+            Just ((Tup as :-> e)) -> f (Map.fromList (zip [ v | Var v _ <- as] xs')) e 
+            --Just (Right action) -> do action xs' 
+      where xs' = map (le env) xs
+    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 (Cast v nt) | Lit i _ <- le env v = return (Lit i nt)
+    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 -> 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]))
+        | 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  
+--        | t == tagApply = f mempty (Eval (xs !! 0) :>>= (n1, Apply n1 (xs !! 1))) 
+        | 'F':rs <- t' = f mempty (App (toAtom $ 'f':rs) xs)
+        | 'B':rs <- t' = f mempty (App (toAtom $ 'b':rs) xs)
+        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 Unit Unit = 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   = fail "unbindable"    -- check type to be sure
+    --bind v r | runIdentity (tc te v) == runIdentity (tc te r)  = fail "unbindable"    -- check type to be sure
+    --bind x y = error $ "bad bind: " ++ show (x,y)
+
addfile ./Grin/Parse.hs
hunk ./Grin/Parse.hs 1
+module Grin.Parse where
+
+import Text.ParserCombinators.Parsec.Language(haskellStyle)
+import Text.ParserCombinators.Parsec.Token
+import Atom
+import Char
+
+tp = haskellStyle {
+   reservedOpNames = ["=","<-","->"],
+   reservedNames = ["return","fetch","store","update","case", "end"]
+   }   
+
+
+exp = 
+
+val = try unit <|> parens tp node  <|>  liti <|> litc <|> var where
+    unit = symbol "()" >> return Unit 
+    liti = do x <- integer tp; return $ Lit (fromIntegral x) tInt  
+    litc = do x <- charLiteral tp; return $ Lit (chr x) tChar
+    tag = do
+        t@(c:_) <- identifier tp
+        if isUpper c then return $ Tag (toAtom t) else return (Var (atomIndex $ toAtom t) TyUnit)
+    node = do
+        n <- cov
+        
+
+
+
addfile ./Grin/PointsTo.hs
hunk ./Grin/PointsTo.hs 1
+module Grin.PointsTo(grinInlineEvalApply) where
+
+import Atom
+import CharIO
+import Char(isDigit)
+import Control.Exception(evaluate)
+import Control.Monad.Identity
+import Control.Monad.State
+import Control.Monad.Writer
+import Data.Monoid
+import DDataUtil
+import Debug.Trace
+import Doc.DocLike
+import FixpointFinder
+import GenUtil
+import Grin.Grin
+import Grin.HashConst
+import Grin.Whiz
+import List(sort)
+import List(transpose,intersperse)
+import Maybe
+import Monad
+import Options
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Doc.Chars as U
+import qualified FlagDump as FD
+import UniqueMonad
+import Grin.EvalInline
+
+sameLength (_:xs) (_:ys) = sameLength xs ys
+sameLength [] [] = True
+sameLength _ _ = False
+
+data HeapType = Constant | SharedEval | UnsharedEval | Reference | RecursiveThunk
+    deriving(Show)
+
+-- These names make no sense
+-- this analysis could probably be strongly typed.
+data Pos = 
+    Union [Pos] 
+    | Variable {-# UNPACK #-} !Var
+    | Func {-# UNPACK #-} !Atom
+    | Basic 
+    | PCase Pos [(Atom,Pos)] Pos 
+    | PIf Bool Pos Atom Pos
+    | Ptr {-# UNPACK #-}!Int 
+    | Down Pos {-# UNPACK #-}!Atom {-# UNPACK #-}!Int 
+    | DownTup Pos {-# UNPACK #-}!Int
+    | Arg {-# UNPACK #-} !Atom {-# UNPACK #-}!Int
+    | Con {-# UNPACK #-} !Atom [Pos]
+    | Tuple [Pos]
+    | Complex {-# UNPACK #-}!Atom [Pos]
+    deriving(Ord,Eq)
+--    | Con Val 
+
+instance Show Pos where
+    showsPrec n (Variable v) xs = showsPrec n v xs
+    showsPrec n (Func a) xs = U.lArrow ++ showsPrec n a  xs
+    showsPrec _ Basic xs = 'B':'A':'S':xs
+    showsPrec n (Ptr i) xs = '*':showsPrec n i xs 
+    showsPrec n (Down p a i) xs = show p ++ U.dArrow ++ show a ++ U.dArrow ++ show i ++ xs 
+    showsPrec n (DownTup p i) xs = show p ++ U.dArrow ++ show i ++ xs 
+    showsPrec n (Arg p i) xs = show p ++ U.rArrow ++ show i ++ xs 
+    showsPrec n (Con p i) xs = show p ++ show i ++ xs 
+    showsPrec n (Tuple ps) xs = (parens $ hcat (intersperse "," $ map show ps)) ++ xs
+    showsPrec n (Complex a p) xs = show a ++ tupled (map show p) ++ xs
+    showsPrec n (Union ps) xs =  text "{" ++ hcat (intersperse "," $ map show ps) ++ "}" ++ xs
+    showsPrec n (PCase p as p') xs = text "case" <+> shows p <+> shows as <+> shows p'  $ xs
+    showsPrec n (PIf True p a p') xs = text "if" <+> shows a <+> U.elem <+>  shows p <+> text "then"  <+> shows p' $ xs
+    showsPrec n (PIf False p a p') xs = text "if" <+> shows a <+> U.notElem <+>  shows p <+> text "then"  <+> shows p' $ xs
+
+instance Monoid Pos where
+    mempty = Union []
+    mappend (Union []) x = x
+    mappend x (Union []) = x
+    mappend (Union xs) (Union ys) = mconcat (xs ++ ys)
+    mappend (Union xs) x = mconcat (x:xs) 
+    mappend x (Union xs) = mconcat (x:xs) 
+    mappend x y = mconcat [x,y]
+    mconcat xs = f (snub xs) [] where
+        f [] [] = Union []
+        f [] [x] = x
+        f [] xs = Union xs
+        f (Tuple ps:Tuple ps':xs) ys | sameLength ps ps'  = f (Tuple [ mappend x y | x <- ps | y <- ps']:xs) ys
+        f (Con a ps:Con a' ps':xs) ys | a == a' && sameLength ps ps'  = f (Con a [ mappend x y | x <- ps | y <- ps']:xs) ys
+        f (DownTup (Tuple vs) n:xs) ys = f ((vs !! n):xs) ys
+        f (x:xs) ys = f xs (x:ys)
+
+
+type Index = Int
+
+-- Optimized DataFlow equations
+data OPos = 
+    OVal !Index
+    | ODown OUnion !Tag !Int
+    | OIf OUnion (Either Index Tag) OUnion
+    | ONode !Atom [OUnion]
+    | OCase !Index [(Tag,OUnion)] OUnion
+    | ORestrictEval  OUnion
+    | OFetch OUnion 
+    | OApply OUnion OUnion
+        deriving(Eq,Ord,Show)
+
+data OUnion = OUnion ValueSet [OPos]
+        deriving(Eq,Ord,Show)
+        {-! derive: Monoid !-}
+
+normalizeOUnion (OUnion vs ops) = OUnion vs (snub ops)
+
+fixupOPos (OApply x y) = do
+    x <- fixupOUnion x
+    y <- fixupOUnion y
+    return $ OApply x y 
+fixupOPos (OFetch x) = do
+    x <- fixupOUnion x
+    return $ OFetch x
+fixupOPos (ORestrictEval x) = do
+    x <- fixupOUnion x
+    return $ ORestrictEval x
+fixupOPos (ODown x a i) = do
+    x <- fixupOUnion x
+    return $ ODown x a i
+fixupOPos (OIf x a y) = do
+    x <- fixupOUnion x
+    y <- fixupOUnion y
+    --a <- evaluate a
+    return $ OIf x a y
+fixupOPos (ONode a xs) = do
+    xs <- mapM fixupOUnion xs
+    return $ ONode a xs
+fixupOPos (OCase a xs els) = do
+    xs <- sequence [ fixupOUnion x >>= return . (,) t | (t,x) <- xs]
+    els <- fixupOUnion els
+    return $ OCase a xs els
+fixupOPos x = return x
+
+fixupOUnion :: OUnion -> IO OUnion
+fixupOUnion (OUnion vs xs) = do
+    xs <- mapM fixupOPos xs
+    --xs <- mapM evaluate (snub xs)
+    return $ ((OUnion $ vs) $ xs) 
+
+
+oVal x = OUnion mempty [x]
+oVar x = oVal (OVal x)
+oConst x = OUnion x []
+
+data ValueSet = VsEmpty | VsNodes !(Map.Map Atom [ValueSet]) | VsHeaps !(Set.Set Int) | VsBas
+    deriving(Eq,Ord)
+    {-! derive: is !-}
+
+
+getHeaps VsEmpty = Set.empty
+getHeaps (VsHeaps s) = s
+getHeaps x = error $ "getHeaps: " ++ show x
+
+getNodes VsEmpty = Map.empty
+getNodes (VsNodes s) = s
+getNodes x = error $ "getNodes: " ++ show x
+
+vsBas = VsBas
+setNodes [] = VsEmpty
+setNodes xs = VsNodes (Map.fromList xs)
+setHeaps [] = VsEmpty
+setHeaps xs = VsHeaps (Set.fromList xs)
+
+instance Monoid ValueSet where
+    mempty = VsEmpty 
+    mappend VsEmpty x = x
+    mappend x VsEmpty = x
+    mappend VsBas VsBas = VsBas
+    mappend (VsHeaps a) (VsHeaps b) = VsHeaps (Set.union a b)
+  --  mappend x@(VsNodes a) y@(VsNodes b)
+     --   | toAtom "CChar" `Map.member` a && toAtom "CInt" `Map.member` b = error $ "Bad Types appended: " ++ parens (show x) <+> parens (show y)
+--        | toAtom "CInt" `Map.member` a && toAtom "P1_2056" `Map.member` b = error $ "Bad Types appended: " ++ parens (show x) <+> parens (show y)
+--        | toAtom "P1_2056" `Map.member` a && toAtom "CInt" `Map.member` b = error $ "Bad Types appended: " ++ parens (show x) <+> parens (show y)
+    mappend (VsNodes a) (VsNodes b) = VsNodes (Map.unionWith (zipWith mappend) a b)
+    mappend x y = error $ "mappend: " ++ show x <+> show y
+
+instance Show ValueSet where
+    showsPrec x VsEmpty = \xs -> '{':'}':xs
+    showsPrec x VsBas = \xs -> 'B':'a':'s':xs
+    showsPrec x (VsHeaps s) 
+        | Set.size s > 7  = braces (hcat (intersperse (char ',') $ map tshow  (take 7 $ Set.toAscList s)) <> text ",...") 
+        | otherwise  = braces (hcat (intersperse (char ',') $ map tshow  ( Set.toAscList s)) ) 
+
+    showsPrec x (VsNodes n) = braces (hcat (intersperse (char ',') (map f $ Map.toAscList n))) where
+        f (t,vs) = tshow t <> tupled (map tshow vs)
+
+
+data PointsTo = PointsTo {
+    ptVars :: Map.Map Var ValueSet,
+    ptFunc :: Map.Map Atom ValueSet, 
+    ptHeap :: Map.Map Int ValueSet,
+    ptHeapType :: Map.Map Int HeapType
+    }
+    deriving(Show)
+    {-! derive: Monoid, update !-}
+
+pointsToStats :: PointsTo -> String
+--pointsToStats pt = text "PointsTo Analysis results:" <$> f "Variables" (ptVars pt) <$> f "Functions" (ptFunc pt) <$> f "Heap" (ptHeap pt) where
+pointsToStats pt = text "PointsTo Analysis results:" <$> buildTable ["Total", "Empty", "Basic", "Max", "Average" ] [f "Variables" (Map.filterWithKey (\k _ -> k /= app_var) $ ptVars pt), f "Functions" (ptFunc pt), f "Heap" (ptHeap pt)] where
+    f n mp = {- text n <> char ':' <+> -}  vs n (Map.elems mp)
+    vs n xs = (n,[tshow $ length xs, show (count isVsEmpty xs),show (count isVsBas xs),show (maximum $ 0:map num xs), show (fromIntegral (sum (map num xs)) / fromIntegral (length xs))] )
+    --        sn "Total" (length xs) <+> 
+    --        sn "Empty" (count isVsEmpty xs) <+>  
+    --        sn "Basic" (count isVsBas xs) <+> 
+    --        sn "Max  " (maximum $ map num xs) <+> 
+    --        sn "Average" (fromIntegral (sum (map num xs)) / fromIntegral (length xs)) 
+    --sn x n | n > 0 = text x <> char ':' <+> tshow n
+    --       | otherwise = empty
+    num (VsNodes x) = Map.size x
+    num (VsHeaps x) = Set.size x
+    num _ = 0
+    
+
+
+
+{-
+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 ])
+--newtype HeapLoc = HeapLoc Int
+--    deriving(Ord,Eq,Num)
+-}
+
+        
+        
+
+
+data PointsToEq = PointsToEq {
+    varEq  :: [(Var, Pos)],
+    funcEq :: [(Atom,Pos)],
+    heapEq :: [(Int,(HeapType,Pos))],
+    updateEq :: [(Pos,Pos)],
+    applyEq :: [(Pos,Pos)],
+    --hcheapEq :: HcHash,
+    appEq  :: [(Atom,[Pos])]
+
+    }
+    deriving(Show)
+    {-! derive: Monoid, update !-}
+
+flattenPointsToEq eq = varEq_u f . funcEq_u f . heapEq_u h . appEq_u g $ eq  where
+    f xs = [ (x, mconcat $ snds xs)  | xs@((x,_):_) <- sortGroupUnder fst xs] 
+    --g xs = [ (x, map mconcat $ transpose (snds xs))  | xs@((x,_):_) <- sortGroupUnder fst xs] 
+    g xs = xs 
+    h xs = [ (x, (t,mconcat $ snds $ snds xs))  | xs@((x,(t,_)):_) <- sortGroupUnder fst xs] 
+
+
+
+data L = Lv {-# UNPACK #-} !Var | Lh {-# UNPACK #-} !Int | Lf {-# UNPACK #-} !Atom
+    deriving(Ord,Eq)
+
+instance Show L where
+    showsPrec n (Lv v) = showsPrec n v
+    showsPrec n (Lh v) = showsPrec n v
+    showsPrec n (Lf v) = showsPrec n v
+
+    
+
+
+newHeap ht p@(Con a ps)
+    | tagIsSuspFunction a, Identity t <- tagToFunction a = newHeap' ht (mappend p (Func t))
+--    | 'B':xs <- fromAtom a = newHeap' ht (mappend p (Func $ toAtom ('b':xs)))
+--    | 'F':xs <- fromAtom a = newHeap' ht (mappend p (Func $ toAtom ('f':xs)))
+newHeap ht p = newHeap' ht p
+
+    
+newHeap' ht p = do
+    h <- newUniq
+    tell mempty { heapEq = [(h,(ht,p))] }
+    return (Ptr h)
+
+bind (Var v _) p = tell mempty { varEq = [(v, p)] }
+bind (NodeC t [Lit {}]) _ = return ()
+bind (NodeC t vs) p | sameLength vs vs' = tell mempty { varEq = vs' }  where   
+    vs' = [ (v,if basicType ty then Basic else Down p t i) | Var v ty <- vs | i <- [0..] ]
+    basicType (Ty _) = True
+    basicType _ = False
+bind (Tup []) _ = return ()
+bind (Tup vs) p | sameLength vs vs' = tell mempty { varEq = vs'  }  where 
+    vs' = [ (v,if basicType ty then Basic else DownTup p i) | Var v ty <- vs | i <- [0..] ]
+    basicType (Ty _) = True
+    basicType _ = False
+--bind _ Basic = return ()
+bind x y = error $ unwords ["bind:",show x,show y] 
+
+analyze :: Grin -> IO PointsTo
+analyze grin@(Grin { grinTypeEnv = typeEnv, grinFunctions = grinFunctions, grinCafs = cafs }) = do
+    let f (eq,hc) (n,l) | n == funcEval = (eq,hc)
+        f (eq,hc) (n,l) | n == funcApply = (eq,hc)
+        f (eq,hc) (n,l) = mapFst (mappend eq) $ collect hc (mh eq + 1) n l 
+        mh PointsToEq { heapEq = xs } = maximum $ 1:fsts xs    
+        toHEq (NodeC t []) | not (tagIsWHNF t) = return (SharedEval,Union [Con t [], func (fromAtom t) ] )
+        toHEq node = toPos node >>= return . (,) Constant
+        (heapEq',hc') = runState (sequence [ toHEq node >>= return . (,) h | (v,node) <- cafs | h <- [1..] ]) emptyHcHash
+        eq = mempty { 
+            --heapEq = [ (h,(SharedEval,Union [Con t [], func (fromAtom t) ] )) | (v,NodeC t []) <- cafs | h <- [1..] ],
+            --varEq =  [ (v,Ptr h) | (v,NodeC t []) <- cafs | h <- [1..] ]
+            heapEq = heapEq', -- [ (h,toHEq node) | (v,node) <- cafs | h <- [1..] ],
+            varEq =  [ (v,Ptr h) | (v,_) <- cafs | h <- [1..] ]
+            }
+        (neq,hc) = mapFst flattenPointsToEq $ foldl f  (eq,hc') grinFunctions         
+        func ('B':xs) = Func $ toAtom $ 'b':xs
+        func ('F':xs) = Func $ toAtom $ 'f':xs
+    when (dump FD.Eval) $ do
+        mapM_ CharIO.print $ sort $ varEq neq
+        mapM_ CharIO.print $ Map.toList (Map.fromListWith (zipWith mappend) (appEq neq))
+        mapM_ CharIO.print $ sort $ funcEq neq
+    findFixpoint'' grin hc neq
+
+-- create an eval suitable for inlining.
+createStore ::  TyEnv -> [Tag] -> Lam   
+createStore  te ts 
+    | null cs = n1 :-> Error "Empty Store" (TyPtr TyNode)
+    | otherwise = n1 :->
+        Case n1 cs 
+    where
+    cs = [f t | t <- ts, tagIsTag t ] 
+    f t = (NodeC t vs :-> Store (NodeC t vs)) where
+        (ts,_) = runIdentity $ findArgsType te t
+        vs = [ Var v ty |  v <- [V 4 .. ] | ty <- ts]
+
+grinInlineEvalApply :: Grin -> IO Grin
+grinInlineEvalApply  grin@(Grin { grinTypeEnv = typeEnv, grinFunctions = grinFunctions, grinCafs = cafs }) = do
+    pt <- analyze grin
+    wdump FD.Progress $ do
+        CharIO.putStrLn (pointsToStats pt)
+    --mapM CharIO.print [ v  | v@(_,_) <-  Map.toList (ptFunc pt)]
+    --mapM CharIO.print [ v  | v@(_,_) <-  Map.toList (ptVars pt)]
+    let f (l :-> e) = l :-> g e
+        g (App a [vr@(Var v _)] :>>= vb :-> Return vb' :>>= node@(NodeC {}) :-> e) 
+            | vb == vb', a == funcEval = (Return vr :>>= createEval (HoistedUpdate node) typeEnv (tagsp v)) :>>= vb :-> Return vb' :>>= node :-> g e
+        g (e1 :>>= l) = g e1 :>>= f l 
+        g (App a [vr@(Var v _)]) 
+            | a == funcEval = Return vr :>>= createEval TrailingUpdate typeEnv (tagsp v) 
+        g app@(App a [vr@(Var v _),y])
+            | a == funcApply = case (tags v) of 
+                Just ts ->  Return (Tup [vr,y]) :>>= createApply typeEnv ts
+                Nothing -> error $ "InlineEvalApply: " ++ show app
+        g n@(App a _) 
+            | a == funcApply || a == funcEval = error $ "Invalid evap: " ++ show n
+        g (Store vr@(Var v _)) | Just ts <- tags v = Return vr :>>= createStore typeEnv ts
+        g st@(Store (Var {})) = Error ("Store of basic: " ++ show st) (TyPtr TyNode)
+        g (Case v@(Var vr _) xs) = docase v (map f xs) (tags vr) 
+        g (Case v xs) = Case v (map f xs)
+        g x = x
+        tags v = if x == vsBas then Nothing else Just [ t | t <- Map.keys vs] where
+              vs = getNodes   x
+              x = case Map.lookup v (ptVars pt) of
+                Just x -> x
+                Nothing -> error $ "Tags: " ++ show v
+        tagsp v = snub (concat [ f n |  n <- Set.toList vs ]) where
+            f n = [ t | t <- Map.keys $ getNodes h ]  where
+                Just h = Map.lookup  n (ptHeap pt)
+            vs = getHeaps x
+            Just x = Map.lookup v (ptVars pt)
+        docase v xs Nothing =  Case v xs
+        docase _ ((_ :-> x):_) (Just []) = Error "No Valid alternatives. This Should Not be reachable." (runIdentity $ tc typeEnv x)
+        --docase v xs (Just ts) | null vs && any (`notElem` ns') ts = error $ "Odd Case: " ++ show (v,ns',ts)  where
+        --    (ns,vs) = span isNodeC xs
+        --    ns' = [ t | NodeC t _ :-> _ <- ns ]
+        --    isNodeC (NodeC {} :-> _) = True
+        --   isNodeC _ = False
+        docase v xs (Just ts) | not (null ns && null vs) = if length ns == length ts  then Case v ns else Case v (ns ++ vs) where
+            (ns,vs) = span isNodeC (filter g xs)
+            g (NodeC t _ :-> _) = t `elem` ts
+            g (Var {} :-> _ ) = True
+            g _ = False
+            isNodeC (NodeC {} :-> _) = True
+            isNodeC _ = False
+            --simple (NodeC t [Lit {}] :-> _) = False
+            --simple (NodeC t _ :-> _) = True
+        docase _ ((_ :-> x):_) _ = Error "No Valid alternatives. This Should Not be reachable." (runIdentity $ tc typeEnv x)
+
+
+
+    --CharIO.print $ pt
+    --mapM_ CharIO.print [ (n,flattenPointsToEq $  collect n l) |  (n,l) <- grinFunctions ]
+    return grin { grinFunctions = map (mapSnd f) grinFunctions }
+
+collect :: HcHash -> Int -> Atom -> Lam -> (PointsToEq,HcHash)
+collect hc st fname (Tup vs :-> exp') 
+    | sameLength avs vs = (eq { funcEq = (fname,v):funcEq eq, varEq = varEq eq ++ avs },hc')   where   
+    avs = [ (v,Arg fname n) |  Var v _ <- vs | n <- [0..] ]
+    --((v,eq),hc') = execUniq st $ (runStateT ((runWriterT (f exp'))) hc) 
+    ((v,hc'),eq) = execUniq st $ (runWriterT (runStateT (f exp') hc)) 
+    --((v,hc'),eq) = runWriter $ execUniqT st $ (runStateT  (f exp') hc) 
+    --tell x = lift $ Control.Monad.Writer.tell x
+    f (exp :>>= v :-> exp2) = do
+        p <- g exp
+        bind v p
+        f exp2
+    f exp = g exp
+        
+    g (App fe [v]) | fe == funcEval = do
+        x <- toPos v
+        --tell mempty { appEq = [(funcEval,[x])] }   
+        return $ Complex funcEval [Complex funcFetch [x]] 
+    g (App fe [v,x]) | fe == funcApply = do
+        v <- toPos v
+        x <- toPos x
+        tell mempty { applyEq = [(v,x)] }   
+        return $ Complex funcApply [v,x]
+        --return $ Complex funcEval (Complex funcApply x) 
+        
+    g (App a vs ) | a `notElem` [funcEval,funcApply]  = do
+        vs' <- mapM toPos vs 
+        tell mempty { appEq = [(a,vs')] }   
+        return $ Func a
+    g Return { expValue = n@(NodeC _ (_:_)) } = do
+        p@(Con a ts) <- toPos n
+        case fromAtom a of
+            'F':rs -> tell mempty { appEq = [(toAtom ('f':rs),ts)] }   
+            'B':rs -> tell mempty { appEq = [(toAtom ('b':rs),ts)] }   
+            _ -> return ()
+        return p
+    g (Return { expValue = val }) = toPos val
+    g Store { expValue = NodeC t _ } | t == tagHole = do
+        newHeap RecursiveThunk mempty
+    g Store { expValue = n@(NodeC _ (_:_)) } = do
+        p@(Con a ts) <- toPos n
+        case fromAtom a of
+            'F':rs -> tell mempty { appEq = [(toAtom ('f':rs),ts)] }   
+            'B':rs -> tell mempty { appEq = [(toAtom ('b':rs),ts)] }   
+            _ -> return ()
+        newHeap SharedEval p
+    g (Store { expValue = val }) = do
+        v <- toPos val
+        newHeap SharedEval v
+    g Fetch { expAddress = val } = do
+        p <- toPos val 
+        return $ Complex funcFetch [p]
+    g (Prim p vs) 
+        | Just as <- primRets p = return $ Union [ Con a [] | a <- as]
+        | (_,TyTup []) <- primType p = return Basic 
+        | (_,TyTup ts) <- primType p = return $ Tuple (replicate (length ts) Basic)  
+        | otherwise = return Basic
+    g (Cast v _) = toPos v
+    g (Error {}) = return mempty
+    g (Case d ls) = do
+        p <- toPos d
+        --xs <- sequence [ bind v p >> f exp |  v :-> exp <- ls ]
+        let f'' bnd tg exp = do
+                (v,w) <- listen (bnd >> f exp)
+                let t x = PIf True p tg x -- [(tg,x)] mempty
+                    z xs = [ (t x,t y) |  (x,y) <- xs ]
+                    z' as = [  (a,map t ts)   |  (a,ts) <- as   ]
+                tell (applyEq_u z $ updateEq_u z $ appEq_u z' $  w)
+                return v
+            f' bnd _ exp = bnd >> f exp
+        xs <- sequence [  f' (bind v p) t exp >>= \x -> return (t,x) |  v@(NodeC t _) :-> exp <- ls ]
+        els <- sequence [ bind v p >> f exp |  v@(Var _ _) :-> exp <- ls ]
+        let els' = head (els ++ [mempty])
+        if (length xs + length els == length ls) then
+            return (PCase p xs els')
+              else sequence [ f e | _ :-> e <- ls ] >>= return . mconcat 
+        --return $ mconcat xs
+    g (Update p v) = do
+        p <- toPos p
+        v <- toPos v
+        tell mempty { updateEq = [(p,v)] }   
+        return Basic
+    g x = error $ unwords ["g",show x]
+
+toPos (NodeC tag vs) = do
+    vs' <- mapM toPos vs 
+    return $ Con tag vs'
+toPos (Const v) = do
+    (_,h) <- newConst' True v
+    return $ Ptr (-h)
+--    p <- toPos v
+--    newHeap Constant p
+toPos (Tup []) = return Basic
+toPos (Tup xs) = do
+    vs' <- mapM toPos xs
+    return $ Tuple vs'
+toPos (Lit {}) = return Basic
+toPos (Var v _)  = return $ Variable v
+toPos u | u == unit = return Basic
+toPos x  = error $ unwords ["toPos:",show x] 
+
+--toPos (Const v) = toPos v
+
+app_var = V (-195000)
+
+convertPos :: Grin -> HcHash -> PointsToEq -> IO ([OUnion],[(L,Int)])
+convertPos grin hcHash eq = return (xs,ys) where
+    ys = [ (fh l,i) | (i,l,_) <- wholeMap ]
+    fh (Lh h) = Lh $ convertHeap h
+    fh x = x
+    xs = snds $  sortUnder fst [ (i,p) | (i,_,p) <- wholeMap ]
+    vars = (Lv app_var,apps):[ (Lv x,cp y) | (x,y) <- varEq eq ] 
+    heaps = [ (Lh x, cp y `mappend` getUpdates ht (convertHeap x) ) | (x,(ht,y)) <- heapEq eq ] ++ cheaps where
+        cheaps = [ (Lh (-x),oNode t (map z xs)) | (x,HcNode t xs) <- hcHashGetNodes hcHash ] where
+        z (Right n) = oConst $ setHeaps [(convertHeap (-n))] 
+        z (Left (Var v _)) = oVar $ convertVar v
+        z (Left (Lit _ _)) = oConst vsBas
+        z (Left (Tag t)) = oConst vsBas
+        oNode t [] = oConst (setNodes [(t,[])])
+        oNode t xs = oVal (ONode t xs)
+    funcs = [ (Lf x,cp y) | (x,y) <- Map.toList $ Map.fromListWith mappend $ funcEq eq ] 
+    wholeMap = [ (i,x,y) |  (x,y) <- (vars ++ heaps ++ funcs) | i <- [0..] ]
+    varsMap = Map.fromList  [ (v,i) | (i,Lv v,_) <- wholeMap  ]
+    heapsMap = Map.fromList [ (v,i) | (i,Lh v,_) <- wholeMap ] 
+    funcsMap = Map.fromList [ (v,i) | (i,Lf v,_) <- wholeMap ] 
+    convertVar v | Just x <- Map.lookup v varsMap = x
+    convertVar v | otherwise = error $ "convertVar: " ++ show v 
+    convertHeap v | Just x <- Map.lookup v heapsMap = x
+    convertFunc v | Just x <- Map.lookup v funcsMap = x
+    convertFunc v = error $ "convertFunc: " ++ show v
+    funcMap = Map.fromListWith (zipWith mappend) $ appEq eq
+    getUpdates RecursiveThunk p =
+        let e (x,c) = OIf (cp x) (Left p) (cp c) 
+        in OUnion mempty (map e (updateEq eq)) 
+    getUpdates _ _ = mempty
+    cp (Func a) = oVar (convertFunc a)
+    cp (Variable a) = oVar (convertVar a)
+    cp (Ptr h) = oConst (setHeaps [convertHeap h])
+    cp (Union ps) = mconcat $ map cp ps 
+    cp Basic = oConst vsBas
+    cp (PIf True (x) tg v) = oVal (OIf (cp x) (Right tg) (cp v))
+    cp (PCase (Variable x) xs e) = oVal (OCase (convertVar x) [ (t,cp v) | (t,v) <- xs ] (cp e))
+    cp (Down x a i) = oVal (ODown (cp x) a i) 
+    cp (DownTup x i) = oVal (ODown (cp x) (toAtom "") i) 
+    cp (Con a []) = oConst (setNodes [(a,[])])
+    cp (Con a ps) = oVal (ONode a (map cp ps))
+    cp (Tuple []) = oConst vsBas
+    cp (Tuple ps) = cp (Con (toAtom "") ps)
+    cp (Complex a [p]) 
+        | a == funcFetch = oVal (OFetch (cp p))
+        | a == funcEval = oVal (ORestrictEval (cp p))
+    cp (Complex a [v,x]) | a == funcApply = oVal $ OApply (cp v) (cp x)
+    cp exp@(Arg a i) = mconcat (asd:cps) where
+        asd = case Map.lookup a funcMap of
+            Just ps | i >= length ps -> error $ "Arg i to large: " ++ show exp
+            Just ps -> cp (ps !! i) 
+            Nothing -> mempty
+        pt = partialTag a 1
+        cps | 'f':_ <- fromAtom a, i < length as - 1 = [oVal (ODown (oVar appVar) pt i)]
+            | 'f':_ <- fromAtom a = map f (applyEq eq)
+            | otherwise = []
+        --f (v,x) 
+        --    | i == length as - 1 =  oVal (OIf (cp v) (Right pt) (cp x)) 
+        --    | otherwise = oVal (ODown (cp (v)) pt i) 
+        f (v,x) = oVal (OIf (cp v) (Right pt) (dpt v x)) 
+        dpt _ x | i == length as - 1 = cp x
+        dpt v x = oVal (ODown (cp (v)) pt i) 
+        Identity (as,_) = findArgsType (grinTypeEnv grin) a 
+    apps = mconcat [ cp v |  (v,_) <- (applyEq eq)]
+    appVar = convertVar app_var
+
+    
+hcHashGetNodes (HcHash _ hc) = [ (x,n) | (n,x) <- Map.toList hc ]
+
+findFixpoint'' :: Grin -> HcHash -> PointsToEq -> IO PointsTo 
+findFixpoint'' grin hcHash eq = do
+    --CharIO.putErrLn "Converting Pos..."
+    (xs,ms) <- convertPos grin hcHash eq
+    xs <- mapM fixupOUnion xs
+    when (dump FD.Eval) $ do
+        mapM_ CharIO.print [ (l,xs !! i) | (l,i) <- ms ]
+    --CharIO.putErrLn "Converted Pos..."
+    let ptagMap = Map.fromList [ (partialTag v 1,x) | (Lf v,x) <- ms, 'f' == head ( fromAtom v) ]
+    let zs = map (go ptagMap) xs 
+    rs <- solve' mempty zs 
+    when (dump FD.Eval) $ do
+        mapM_ CharIO.print [ (l,rs !! i) | (l,i) <- ms ]
+    --CharIO.putErrLn "Fixpoint Finished..."
+    let mp x = Map.findWithDefault (error "findFixpoint''") x $ Map.fromAscList $  zip [0..] rs
+    return  PointsTo { 
+        ptVars = Map.fromList [ (v,mp x) | (Lv v,x) <- ms ],
+        ptFunc = Map.fromList [ (v,mp x) | (Lf v,x) <- ms ],
+        ptHeap = Map.fromList [ (v,mp x) | (Lh v,x) <- ms ],
+        ptHeapType = Map.fromList [ (h,t) | (h,(t,_)) <- heapEq eq ]
+        } where
+    go ptagMap u env = cu u
+        where
+        cu (OUnion v ps) = do
+            xs <- mapM cp ps
+            return (mconcat (v:xs)) 
+        cp (OVal i) = getVal' env i
+        cp (OIf i (Left t) x) = do
+            v <- cu i
+            case t `Set.member` getHeaps v of
+                True -> cu x
+                False -> return mempty
+        cp (OIf i (Right t) x) = do
+            v <- cu i
+            case t `Map.lookup` getNodes v of
+                Just _ -> cu x
+                Nothing -> return mempty
+        cp (OCase i xs els) = do
+            v <- liftM getNodes $ getVal' env i 
+            let f (t,x) = case Map.lookup t v of 
+                    Just _ -> [cu x]
+                    Nothing ->  []
+            xs <- sequence $  concatMap f xs
+            x <- cu els   -- TODO should only do else case if no match
+            return (mconcat $ x:xs)
+            --case xs of
+            --    [] -> cu els
+            --    _ -> return $ mconcat xs
+        cp exp@(ODown x t i) = do     
+            nds <- liftM getNodes $ cu x 
+            case Map.lookup t nds of
+                Just ps | i >= length ps -> error $ "ODown i to large: " ++ show exp ++ show ps
+                Just as -> return $ as !! i
+                Nothing -> return mempty
+        cp (ONode a ps) = do
+            ps <- mapM cu ps
+            return (setNodes [(a,ps)])
+        cp (OFetch p) = do
+            hp <- liftM getHeaps $ cu p
+            vs <- mapM (getVal' env) (Set.toList hp)
+            return $ mconcat vs
+        cp (ORestrictEval p) = do
+            vs <- cu p 
+            return $ VsNodes (Map.filterWithKey (\t _ -> tagIsWHNF t) (getNodes vs)) 
+        cp (OApply v x) = do
+            vs <- cu v 
+            xs <- case  [ papp ( t) as  | (t,as) <- Map.toList (getNodes vs), tagIsPartialAp t ]  of
+                [] -> return []
+                xs -> do
+                    x' <- cu x
+                    mapM ($ x') xs
+            return $ mconcat xs
+                
+        papp t _ _ | Just x <- Map.lookup t ptagMap = getVal' env x 
+        papp t  as x | ('P':cs) <- fromAtom t, (n','_':rs) <- span isDigit cs, n <- read n', n > 1 =  return $ setNodes [((toAtom $ 'P':(show $ n -  (1::Int)) ++ "_" ++ rs),(as ++ [x]))]
+
+findFixpoint' :: HcHash -> PointsToEq -> IO PointsTo 
+findFixpoint' (HcHash _ mp) eq = fmap cpt (solve' mempty (snds fs)) where 
+    cpt xs = PointsTo { 
+        ptVars = Map.fromList [ (v,x) | (Lv v,x) <- zip fs' xs ],
+        ptFunc = Map.fromList [ (v,x) | (Lf v,x) <- zip fs' xs ],
+        ptHeap = Map.fromList [ (v,x) | (Lh v,x) <- zip fs' xs ],
+        ptHeapType = Map.fromList [ (h,t) | (h,(t,_)) <- heapEq eq ]
+        }
+    fs = vars ++ heaps ++ funcs
+    fs' = fsts fs
+    vars = [ (Lv x,cp' y) | (x,y) <- varEq eq ] 
+    heaps = [ (Lh x,\env -> cp' y env >>= \z -> getUpdates env x >>= return . mappend z ) | (x,(_,y)) <- heapEq eq ] ++ cheaps 
+    cheaps = [ (Lh (-x),\_ -> return $ setNodes  [(t,(map z xs))]) | (HcNode t xs,x) <- Map.toList mp ] where
+        z (Right n) = setHeaps [(-n)] 
+        z (Left _) = vsBas
+    funcs = [ (Lf x,cp' y) | (x,y) <- funcEq eq ] 
+    fmp = Map.fromListWith (zipWith mappend) $ appEq eq
+    valMap = Map.fromList (zip fs' [0..])
+    varsMap = Map.fromList  [ (v,i) | (Lv v,_) <- vars | i <- [0..] ]
+    heapsMap = Map.fromList [ (v,i) | (Lh v,_) <- heaps | i <- [length vars ..]] 
+    funcsMap = Map.fromList [ (v,i) | (Lf v,_) <- funcs | i <- [length vars + length heaps ..]] 
+    getUpdates env p = do
+        let e (v,x) = do
+                ns <- cp' v env
+                case Set.member p (getHeaps ns) of
+                    True -> cp' x env
+                    False -> return mempty
+        ep <-  mapM e (updateEq eq) 
+        return $ mconcat ep
+    cp' v env = cp v where
+        --getVal h = getVal' env (Map.find h valMap)
+        cp (Union ps) = fmap mconcat (mapM cp ps)
+        cp (Variable v) = getVal' env x where
+            --Just x =  (Map.lookup v varsMap)
+            x = case (Map.lookup v varsMap) of
+                Just x -> x
+                Nothing -> error $ "Can't find var: " ++ show v
+        cp (Func a) = getVal' env x where
+            x = case (Map.lookup a funcsMap) of
+                Just x -> x
+                Nothing -> error $ "Can't find func: " ++ show a
+        cp Basic = return $ vsBas
+        cp (Ptr a) = return $ setHeaps [a]
+        cp (PIf True p tg v) = do
+            w <- cp p
+            case Map.lookup tg (getNodes w) of
+                Nothing -> return mempty
+                Just _ -> cp v
+        cp (PIf False p tg v) = do
+            w <- cp p
+            case Map.lookup tg (getNodes w) of
+                Just _ -> return mempty
+                Nothing -> cp v
+        cp (PCase p xs e) = do
+            w <- cp p
+            let mp = Map.fromList xs
+            xs <- sequence [ maybe (cp e) cp (Map.lookup t mp) |  t <-  Map.keys $ getNodes w] 
+            return $ mconcat xs
+        cp x@(Down p a i) = do
+            vs <-  cp p 
+            when (vs == VsBas) $ fail ("VsBas: " ++ show x)  
+            case Map.lookup a (getNodes vs) of
+                Just as -> return (as !! i)
+                Nothing -> return mempty
+                --[ as !! i |  (a',as) <- vs, a' == a ]
+        cp (DownTup p i) = cp (Down p (toAtom "") i)
+        cp z@(Arg a i) = do 
+            da <- case Map.lookup a fmp of
+                Just ps -> cp (ps !! i) >>= return . (:[])
+                Nothing -> return []
+            ep <- return [] 
+            {-
+            ea <- case Map.lookup funcEval fmp of 
+                Just [p] -> do
+                    ns <-   cp p 
+                    hs <- mapM getVal [ Lh h |  h <- Set.toAscList $ getHeaps ns ]
+                    let pts = [ as !! i |  Just as <-  (map (Map.lookup (partialTag a 0) . getNodes) hs)]
+                    return $  pts
+                Nothing -> return []
+            -}
+            let  e (v,x) = do
+                    let pt = partialTag a 1
+                    ns <-  cp v 
+                    when (ns == VsBas) $ fail ("VsBas: " ++ show z)  
+                    case Map.lookup pt (getNodes ns) of
+                        Just as | length as == i -> cp x >>= return . (:[])
+                        Just as -> return [as !! i]
+                        Nothing -> return []
+            ep <- if 'f' == head (fromAtom a) then mapM e (applyEq eq) else return []
+            return (mconcat $ da  ++ concat ep)
+        cp (Con a ps) = do
+            ps' <- mapM cp ps
+            return $ setNodes [(a,ps')] 
+        cp (Tuple []) = return VsBas
+        cp (Tuple ps) = cp (Con (toAtom "") ps)
+        cp (Complex a [p]) 
+            | a == funcFetch = do
+                hs <- cp p 
+                vs <- mapM (getVal' env) [ maybe (error "Can't find heap") id $ Map.lookup n heapsMap | n <- Set.toAscList $ getHeaps hs] 
+                return $ mconcat vs
+            | a == funcEval = do
+                vs <-  cp p 
+                return $ VsNodes (Map.filterWithKey (\t _ -> tagIsWHNF t) (getNodes vs)) 
+        cp (Complex a [v,x]) 
+            | a == funcApply = do
+                vs <-  cp v 
+                xs <- case  [ papp (fromAtom t) as  | (t,as) <- Map.toList (getNodes vs), tagIsPartialAp t ]  of
+                    [] -> return []
+                    xs -> do
+                        x' <- cp x
+                        mapM ($ x') xs
+                return $ mconcat xs
+                
+        papp ('P':'1':'_':xs) _ _ = getVal' env (runIdentity $ Map.lookup (toAtom $ 'f':xs) funcsMap) -- cp (Func (toAtom $ 'f':xs))
+        papp ('P':cs) as x | (n','_':rs) <- span isDigit cs, n <- read n', n > 1 =  return $ setNodes [((toAtom $ 'P':(show $ n -  (1::Int)) ++ "_" ++ rs),(as ++ [x]))]
+        
+
+{-
+    f (exp :>>= Var v _ :-> exp2) = do
+        p <- g exp
+        tell mempty { varEq = [(v, p)] }
+        f exp2
+    f (exp :>>= NodeC t vs :-> exp2) = do
+        p <- g exp
+        tell mempty { varEq = [ (v,Down p t i) | Var v _ <- vs | i <- [1..] ] }
+        f exp2
+-}
+{-
+data Value = 
+    Node Atom [ValueSet] 
+    | Bas 
+    | Heap Int 
+    deriving(Eq,Ord)
+
+newtype ValueSet = ValueSet (Set.Set Value)
+
+
+
+instance Eq ValueSet where
+    a == b = valueSetToList a == valueSetToList b
+    a /= b = valueSetToList a /= valueSetToList b
+    
+instance Ord ValueSet where
+    compare a b = compare (valueSetToList a) (valueSetToList b)
+
+
+instance Show Value where
+    showsPrec x (Heap n) = showsPrec x n 
+    showsPrec x Bas = \xs -> ('B':'a':'s':xs)
+    showsPrec x (Node a vs) 
+        | a == toAtom "" = tupled  (map (showsPrec x) vs) 
+        | otherwise = showsPrec x a . tupled (map (showsPrec x) vs) 
+
+instance Show ValueSet where
+    showsPrec x vs' 
+        | length vs > 10 = showsPrec x (take 10 vs) . ("... " ++)
+        | otherwise = showsPrec x vs
+        where vs = valueSetToList vs'
+
+
+--valueSetToList (ValueSet vs) = vs
+--valueSet vs = ValueSet (snub vs)
+
+valueSetToList (ValueSet vs) = Set.toAscList vs
+valueSet vs = ValueSet (Set.fromList vs)
+
+
+
+instance Monoid ValueSet where
+    mempty = ValueSet Set.empty
+    mappend x y = mconcat [x,y]
+    mconcat [] = mempty
+    mconcat [x] = x
+    mconcat xs =  f [] $ Set.toAscList (Set.unions [ vs | ValueSet vs <- xs]) where
+        f xs [] = valueSet xs
+        f xs (Node a vs:Node b vs':xs') | a == b = f xs (Node a (zipWith mappend vs vs'):xs')
+        f xs (y:ys) = f (y:xs) ys
+
+instance Monoid ValueSet where
+    mempty = ValueSet []
+    mappend x y = mconcat [x,y]
+    mconcat xs = ValueSet $ f [] $ snub $ concat [ vs | ValueSet vs <- xs] where
+        f xs [] = xs
+        f xs (Node a vs:Node b vs':xs') | a == b = f xs (Node a (zipWith mappend vs vs'):xs')
+        f xs (y:ys) = f (y:xs) ys
+
+findFixpoint :: HcHash -> PointsToEq -> IO PointsTo 
+findFixpoint (HcHash _ mp) eq = fmap cpt (solve mempty fs) where 
+    cpt xs = PointsTo { 
+        ptVars = Map.fromList [ (v,x) | (Lv v,x) <- xs ],
+        ptFunc = Map.fromList [ (v,x) | (Lf v,x) <- xs ],
+        ptHeap = Map.fromList [ (v,x) | (Lh v,x) <- xs ],
+        ptHeapType = Map.fromList [ (h,t) | (h,(t,_)) <- heapEq eq ]
+        }
+    fs = vars ++ heaps ++ funcs
+    vars = [ (Lv x,cp y) | (x,y) <- varEq eq ] 
+    heaps = [ (Lh x,cp y) | (x,(_,y)) <- heapEq eq ] ++ cheaps 
+    cheaps = [ (Lh (-x),return $ valueSet [Node t (map z xs)]) | (HcNode t xs,x) <- Map.toList mp ] where
+        z (Right n) = valueSet [Heap (-n)] 
+        z (Left _) = valueSet [Bas]
+    funcs = [ (Lf x,cp y) | (x,y) <- funcEq eq ] 
+    fmp = Map.fromList $ appEq eq
+    cp (Union ps) = fmap mconcat (mapM cp ps)
+    cp (Variable v) = getVal (Lv v) 
+    cp (Func a) = getVal (Lf a)
+    cp Basic = return $ valueSet [Bas]
+    cp (Ptr a) = return $ valueSet [Heap a]
+    cp (Down p a i) = do
+        vs <- fmap valueSetToList $ cp p 
+        return $ mconcat [ as !! i | Node a' as <- vs, a' == a ]
+    cp (DownTup p i) = do
+        vs <- fmap valueSetToList $ cp p 
+        return $ mconcat [ as !! i | Node a' as <- vs, a' == toAtom "" ]
+    cp (Arg a i) = do 
+        da <- case Map.lookup a fmp of
+            Just ps -> cp (ps !! i) >>= return . (:[])
+            Nothing -> return []
+        ea <- case Map.lookup funcEval fmp of 
+            Just [p] -> do
+                ns <- fmap valueSetToList $  cp p 
+                hs <- mapM getVal [ Lh h |  Heap h <- ns ]
+                let pts = [ as !! i |  Node t as <- concat (map valueSetToList  hs), t == partialTag a 0]
+                return $  pts
+            Nothing -> return []
+        ep <- case Map.lookup funcApply fmp of 
+            Just [v,x] -> do
+                ns <- fmap valueSetToList $ cp v 
+                x <- cp x
+                let pts = [ (as ++ [x]) !! i |  Node t as <- ns, head (fromAtom a) == 'f',t == partialTag a 1]
+                return $ pts
+            Nothing -> return []
+        return (mconcat $ da ++ ea ++ ep)
+    cp (Con a ps) = do
+        ps' <- mapM cp ps
+        return $ valueSet [Node a ps'] 
+    cp (Tuple ps) = do
+        ps' <- mapM cp ps
+        return $ valueSet [Node (toAtom "") ps'] 
+    cp (Complex a [p]) 
+        | a == funcFetch = do
+            vs <- fmap valueSetToList $  cp p 
+            vs <- mapM getVal [ Lh n | Heap n <- vs] 
+            return $ mconcat vs
+        | a == funcEval = do
+            vs <- fmap valueSetToList $  cp p 
+            return $ valueSet [ n | n@(Node t _) <- vs, tagIsWHNF t ]
+    cp (Complex a [v,x]) 
+        | a == funcApply = do
+            vs <- fmap valueSetToList $  cp v 
+            x' <- cp x 
+            xs <- sequence [ papp (fromAtom t) as x' | Node t as <- vs, tagIsPartialAp t ]  
+            return $ mconcat xs
+            
+    papp ('P':'1':'_':xs) _ _ = cp (Func (toAtom $ 'f':xs))
+    papp ('P':cs) as x | (n','_':rs) <- span isDigit cs = return $ valueSet [Node (toAtom $ 'P':(show $ read n' - (1::Int)) ++ "_" ++ rs) (as ++ [x])]
+findFixpoint :: HcHash -> PointsToEq -> IO PointsTo 
+findFixpoint (HcHash _ mp) eq = fmap cpt (solve mempty fs) where 
+    cpt xs = PointsTo { 
+        ptVars = Map.fromList [ (v,x) | (Lv v,x) <- xs ],
+        ptFunc = Map.fromList [ (v,x) | (Lf v,x) <- xs ],
+        ptHeap = Map.fromList [ (v,x) | (Lh v,x) <- xs ],
+        ptHeapType = Map.fromList [ (h,t) | (h,(t,_)) <- heapEq eq ]
+        }
+    fs = vars ++ heaps ++ funcs
+    vars = [ (Lv x,cp y) | (x,y) <- varEq eq ] 
+    heaps = [ (Lh x,cp y >>= \z -> getUpdates x >>= return . mappend z ) | (x,(_,y)) <- heapEq eq ] ++ cheaps 
+    cheaps = [ (Lh (-x),return $ setNodes  [(t,(map z xs))]) | (HcNode t xs,x) <- Map.toList mp ] where
+        z (Right n) = setHeaps [(-n)] 
+        z (Left _) = vsBas
+    funcs = [ (Lf x,cp y) | (x,y) <- funcEq eq ] 
+    fmp = Map.fromListWith (zipWith mappend) $ appEq eq
+    getUpdates p = do
+        let e (v,x) = do
+                ns <- cp v 
+                case Set.member p (getHeaps ns) of
+                    True -> cp x
+                    False -> return mempty
+        ep <-  mapM e (updateEq eq) 
+        return $ mconcat ep
+    cp (Union ps) = fmap mconcat (mapM cp ps)
+    cp (Variable v) = getVal (Lv v) 
+    cp (Func a) = getVal (Lf a)
+    cp Basic = return $ vsBas
+    cp (Ptr a) = return $ setHeaps [a]
+    cp x@(Down p a i) = do
+        vs <-  cp p 
+        when (vs == VsBas) $ fail ("VsBas: " ++ show x)  
+        case Map.lookup a (getNodes vs) of
+            Just as -> return (as !! i)
+            Nothing -> return mempty
+            --[ as !! i |  (a',as) <- vs, a' == a ]
+    cp (DownTup p i) = cp (Down p (toAtom "") i)
+    cp z@(Arg a i) = do 
+        da <- case Map.lookup a fmp of
+            Just ps -> cp (ps !! i) >>= return . (:[])
+            Nothing -> return []
+        ep <- return [] 
+        {-
+        ea <- case Map.lookup funcEval fmp of 
+            Just [p] -> do
+                ns <-   cp p 
+                hs <- mapM getVal [ Lh h |  h <- Set.toAscList $ getHeaps ns ]
+                let pts = [ as !! i |  Just as <-  (map (Map.lookup (partialTag a 0) . getNodes) hs)]
+                return $  pts
+            Nothing -> return []
+        -}
+        let  e (v,x) = do
+                let pt = partialTag a 1
+                ns <-  cp v 
+                when (ns == VsBas) $ fail ("VsBas: " ++ show z)  
+                pts <- case Map.lookup pt (getNodes ns) of
+                    Just as | length as == i -> cp x >>= return . (:[])
+                    Just as -> return [as !! i]
+                    Nothing -> return []
+                return $ pts
+        ep <- if 'f' == head (fromAtom a) then mapM e (applyEq eq) else return []
+        return (mconcat $ da  ++ concat ep)
+    cp (Con a ps) = do
+        ps' <- mapM cp ps
+        return $ setNodes [(a,ps')] 
+    cp (Tuple []) = return VsBas
+    cp (Tuple ps) = cp (Con (toAtom "") ps)
+    cp (Complex a [p]) 
+        | a == funcFetch = do
+            hs <- cp p 
+            vs <- mapM getVal [ Lh n | n <- Set.toAscList $ getHeaps hs] 
+            return $ mconcat vs
+        | a == funcEval = do
+            vs <-  cp p 
+            return $ VsNodes (Map.filterWithKey (\t _ -> tagIsWHNF t) (getNodes vs)) 
+    cp (Complex a [v,x]) 
+        | a == funcApply = do
+            vs <-  cp v 
+            x' <- cp x 
+            xs <- sequence [ papp (fromAtom t) as x' | (t,as) <- Map.toList (getNodes vs), tagIsPartialAp t ]  
+            return $ mconcat xs
+            
+    papp ('P':'1':'_':xs) _ _ = getVal (Lf (toAtom $ 'f':xs)) -- cp (Func (toAtom $ 'f':xs))
+    papp ('P':cs) as x | (n','_':rs) <- span isDigit cs, n <- read n', n > 1 = return $ setNodes [((toAtom $ 'P':(show $ n -  (1::Int)) ++ "_" ++ rs),(as ++ [x]))]
+    
+-}
addfile ./Grin/Primitives.hs
hunk ./Grin/Primitives.hs 1
+module Grin.Primitives(primSc, builtins) where
+
+import Grin.Val
+import Grin.Grin
+import GenUtil
+import VConsts
+import Atom
+import Char(chr,ord)
+import Options
+import C.Prims
+
+createPrim name as exp = sc where
+    sc = (n,Tup as :-> exp)
+    --tenv = (n,([ v | Var _ v <- as ],TyNode))
+    n = toAtom $ "b" ++ name 
+
+--primAp = createPrim "ap" [p1,p2] (gEval p1 :>>= (n3 :-> gApply n3 p2))
+
+primitive = Primitive { primRets = Nothing }
+
+-- Eval all arguments
+createPrim' name as exp = sc where
+    sc = (n,Tup [ Var n (TyPtr TyNode) | Var n _ <- as ] :-> exp')
+    n = toAtom $ "b" ++ name 
+    exp' = foldr g exp as where
+        g v@(Var x TyNode) r = gEval (Var x (TyPtr TyNode)) :>>= (v :-> r)
+
+litPrim :: Tag -> String -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
+litPrim tag name nargs fn = (createPrim' name as (f as $ Prim prim as'), (n,fn)) where
+    n = toAtom $ "@" ++ name 
+    var n = Var n (Ty tag)
+    as =  [ Var n TyNode | n <- [ v1 .. V nargs ]]
+    as' =  [ var n | n <- [ v1 .. V nargs ]]
+    f [] e = e 
+    f ((a@(Var n _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e 
+    f a b = error $ "litPrim: " ++ show (a,b)
+    prim = primitive { primRets = Just [ toAtom $ "CPrelude." ++ show x | x <- [LT .. ]], primName = n, primType = (TyTup (replicate nargs (Ty tag)),TyNode) , primAPrim = primPrim (show n) }
+
+intPrim :: Tag -> String -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
+intPrim tag name nargs fn = (createPrim' name as (f as (Prim prim as')), (n,fn)) where
+    n = toAtom $ "@" ++ name 
+    var n = Var (V n) (Ty tag)
+    f [] e = e :>>= var 1 :-> Return (NodeC tag [var 1])
+    f ((a@(Var (V n) _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e 
+    as =  [ Var (V n) TyNode | n <- [ 1 .. nargs ]]
+    as' =  [ var n | n <- [ 1 .. nargs ]]
+    prim = primitive { primName = n, primType = (TyTup (replicate nargs (Ty tag)),Ty tag) }
+
+eqPrim :: Tag -> String -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
+eqPrim tag name nargs fn = (createPrim' name as (f as (Prim prim as')), (n,fn)) where
+    n = toAtom $ "@" ++ name 
+    var n = Var (V n) (Ty tag)
+    f [] e = e 
+    f ((a@(Var (V n) _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e 
+    as =  [ Var (V n) TyNode | n <- [ 1 .. nargs ]]
+    as' =  [ var n | n <- [ 1 .. nargs ]]
+    prim = primitive { primRets = Just [toAtom "CPrelude.True", toAtom "CPrelude.False"],primName = n, primType = (TyTup (replicate nargs (Ty tag)),TyNode)  , primAPrim = primPrim (show n)}
+    
+intPrimN :: Tag -> String -> Int -> Int -> Builtin -> ((Atom,Lam),(Atom,Builtin))
+intPrimN tag name nargs 2 fn = (createPrim' name as (f as (Prim prim as')), (n,fn)) where
+    n = toAtom $ "@" ++ name 
+    var n = Var (V n) (Ty tag)
+    f [] e = 
+        e :>>= Tup rs' :-> 
+        Store (NodeC tag [rs' !! 0]) :>>= p1 :-> 
+        Store (NodeC tag [rs' !! 1]) :>>= p2 :-> 
+        Return (NodeC (toAtom "CPrelude.(,)") [p1,p2])
+    f ((a@(Var (V n) _)):as) e = Return a :>>= NodeC tag [var n] :-> f as e 
+    as =  [ Var (V n) TyNode | n <- [ 1 .. nargs ]]
+    as' =  [ var n | n <- [ 1 .. nargs ]]
+    rs' =  [ var n | n <- [ 1 .. 2 ]]
+    prim = primitive { primName = n, primType = (TyTup (replicate nargs (Ty tag)),TyTup (replicate 2 $ Ty tag))  , primAPrim = primPrim (show n)}
+
+--primQuotRem = intPrimN cInt "primQuotRem" 2 2 f where
+--    f [Lit x tx,Lit y ty] | tx == ty = return $  let (a,b) = (quotRem x y) in Tup [Lit a tx, Lit b tx]  
+--    f xs = error $ "primQuotRem: " ++ show xs
+
+fromBoxedLit (NodeC _ [Lit n _]) = return n
+fromBoxedLit _ = fail "not boxed lit"
+
+--binaryOp name op = intPrim (toAtom "int") name 2 f where
+--    f [Lit x tx,Lit y ty] | tx == ty = return $  Lit (x `op` y) tx  
+--    f xs = error $ "binaryOp: " ++ name ++ " " ++ show xs
+
+primId name = createPrim' name [n1] (Return n1)
+
+--primTimes = binaryOp "primTimes" (*)
+--primPlus = binaryOp "primPlus" (+)
+--primMinus = binaryOp "primMinus" (-)
+
+{-
+primPlus = sprim "primPlus" 2 f where
+    f [NodeC tx [Lit x tx'],NodeC ty [Lit y ty']] 
+        | tx == ty && tx' == ty' = return $ NodeC tx [Lit (x + y) tx']  
+primMinus = sprim "primMinus" 2 f where
+    f [NodeC tx [Lit x tx'],NodeC ty [Lit y ty']] 
+        | tx == ty && tx' == ty' = return $ NodeC tx [Lit (x - y) tx']  
+-}
+--primNegate = intPrim cInt "primNegate" 1 f where
+--    f [Lit x tx] = return $ Lit (negate x) tx  
+
+primEq x = eqPrim (toAtom $ 'C':x) ("primEq" ++ x)  2 f where
+    f [Lit x tx,Lit y ty] 
+        | tx == ty  = return $ if x == y then vTrue else vFalse 
+primCompare x = litPrim (toAtom $ 'C':x) ("primCompare" ++ x) 2 f where
+    f [Lit x tx',Lit y ty'] 
+        |  tx' == ty' = return $ vOrdering (compare x y)
+    f xs = error $ "primCompare: " ++ show xs
+
+
+sprims = [
+--    primPlus,
+ --   primMinus,
+--    primNegate,
+--    primEq "Int", 
+--    primEq "Char", 
+--    primCompare "Int", 
+--    primCompare "Char", 
+--    primTimes, 
+    (primPutChar,primPutCharBuiltin),
+    (primGetChar,primGetCharBuiltin),
+    (primGetArgs,primGetArgsBuiltin)
+--    primQuotRem
+    ] 
+
+builtins = snds sprims
+primSc = fsts sprims ++ [
+--    primId "unsafeCoerce",
+--    primId "primFromInteger",
+--    primId "primToInteger",
+--    (toAtom "bord", primLitCast (cChar,tCharzh) (cInt,tIntzh)),
+--    (toAtom "bchr", primLitCast (cInt,tIntzh) (cChar,tCharzh)),
+--    createPrim "error" [p1] (Error "error call" TyNode), 
+    --primAp,
+--    primExit
+    ]
+
+primLitCast (c1,t1) (c2,t2) = (Tup [p1] :->
+    gEval p1 :>>= NodeC c1 [Var v2 t1] :-> 
+    Cast (Var v2 t1) t2 :>>= Var v3 t2 :-> 
+    Return (NodeC c2 [Var v3 t2])
+    )
+
+primitivePutChar = primitive {
+    primName = toAtom "@putChar",
+    primAPrim = primPrim  "@putChar",
+    primType = (TyTup [tCharzh],tyUnit)
+    }
+primitiveGetChar = primitive {
+    primName = toAtom "@getChar",
+    primAPrim = primPrim  "@getChar",
+    primType = (TyTup [],tCharzh)
+    }
+
+primPutCharBuiltin = (primName primitivePutChar, \[Lit n _] -> putChar (chr n) >> return unit)
+primGetCharBuiltin = (primName primitiveGetChar, \[] -> getChar >>= \c -> return (Lit (ord c) tCharzh))
+
+primGetChar = (toAtom "bprimGetChar",
+    Tup [p0] :->
+    Prim primitiveGetChar [] :>>= c1 :->
+    Store (NodeC cChar [c1]) :>>= p2 :-> 
+    Return (NodeC (toAtom "CJhc.IO.JustIO") [p0, p2])
+    )
+
+primPutChar = (toAtom "bprimPutChar",
+    Tup [p1,p0] :->
+    gEval p1 :>>= NodeC cChar [c1] :-> 
+    Prim primitivePutChar [c1] :>>= unit :->
+    Return (NodeC (toAtom "CJhc.IO.JustIO") [p0, Const $ vUnit])
+    )
+
+--  unboxed varients are only different for certain types.
+
+-- binOp :: (ToVal a, ToVal b, FromVal c) =>  ( a -> b -> c) -> ((Atom,Lam),(Atom,Builtin))
+-- binOp fn = 
+
+
+
+
+primGetArgsBuiltin = (primName primitiveGetArgs, \[] -> return $ Const $ toVal (map toVal (optProgArgs options)))
+primitiveGetArgs = primitive {
+    primName = toAtom "@getArgs",
+    primType = (TyTup [],TyPtr TyNode)
+    }
+primGetArgs = (toAtom "bprimGetArgs",
+    Tup [p0] :->
+    Prim primitiveGetArgs [] :>>= p1 :->
+    Return (NodeC (toAtom "CJhc.IO.JustIO") [p0,p1])
+    )
+
+--primExitBuiltin = (primName primitiveExit, \[] -> return $ Const $ toVal (map toVal (optProgArgs options)))
+--primitiveExit = Primitive {
+--    primName = toAtom "@exit",
+--    primType = (TyTup [Ty cInt],tyUnit)
+--    }
+primExit = (toAtom "bexit",
+    Tup [p3,p1] :->
+    gEval p3 :>>= NodeC cInt [Var v1 tIntzh] :->
+    Error "exit" TyNode
+    --Prim primitiveExit [Var 1 (Ty cInt)] :>>= unit :->
+    --Return (NodeC (toAtom "CPrelude.IO.JustIO") [Const $ toVal ()])
+    )
+
+c1 = Var v1 tCharzh
+--world__ = Const (NodeC (toAtom "CJhc.IO.World__") [])
+
+{-
+primIO name action as rt = (createPrim' name as exp ,action) where
+    as' = [ Var | a <- as ++ [TyNode] | v <- [v1 ..]] 
+    exp = Prim Primitive { primName = pn, primType =  
+    pn = toAtom $ "@" ++ name 
+-}
+    
addfile ./Grin/Show.hs
hunk ./Grin/Show.hs 1
+module Grin.Show(prettyFun,prettyVal,prettyExp,printGrin) where
+
+import Grin.Grin
+import Doc.Pretty
+import Doc.PPrint
+import Doc.DocLike
+import Atom
+import Char
+import VConsts
+import ANSI
+import Grin.Val
+import Number
+import Monad
+import CharIO
+import E.Pretty(render)
+
+instance PPrint Doc Val   where
+    pprint v = prettyVal v
+
+instance PPrint Doc Exp   where
+    pprint v = prettyExp empty v
+
+pVar v | v == unit = empty
+pVar v  = pVal v <+> operator "<- " 
+
+pVar' v  = pVal v <+> operator "<- " 
+
+
+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 = color 1 . text
+keyword = color 1 . text 
+tag = text
+func = color 92 . text
+prim = color 91 . text
+--func = text
+--tag = color 92 . text
+
+prettyVal = pVal
+
+isComplex (_ :>>= _) = True
+isComplex _ = False
+{-# 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 v) = vl <> keyword "return" <+> pVal v
+prettyExp vl (Store v) = vl <> keyword "store" <+> pVal v
+prettyExp vl (Fetch v) = vl <> keyword "fetch" <+> pVal v
+prettyExp vl (Error s _) = vl <> keyword "error" <+> tshow s
+prettyExp vl (App t [v]) | t == funcEval = vl <> keyword "eval" <+> pVal v
+prettyExp vl (App t [a,b]) | t == funcApply = vl <> keyword "apply" <+> pVal a <+> pVal b
+prettyExp vl (App a vs)  = vl <> func (fromAtom a) <+> hsep (map pVal vs)
+prettyExp vl (Prim Primitive { primName = nm } vs)  = vl <> prim (fromAtom nm) <+> hsep (map pVal vs)
+prettyExp vl (Update x y) = vl <> keyword "update" <+> pVal x <+> pVal y
+prettyExp vl (Cast x _) = vl <> keyword "cast" <+> pVal x
+prettyExp vl (Case v vs) = vl <> keyword "case" <+> pVal v <+> keyword "of" <$> indent 2 (vsep (map f vs)) where
+    f (v :-> e) = pVal v <+> operator "->" <+> keyword "do" <$> indent 2 (prettyExp empty e)
+
+pVal s | Just st <- fromVal s = text $ show (st::String)
+pVal (NodeC t []) = parens $ tag (fromAtom t)
+pVal (NodeC t vs) = parens $ tag (fromAtom t) <+> hsep (map pVal vs)
+pVal (NodeV (V i) vs) = parens $ char 't' <> tshow i <+> hsep (map pVal vs)
+pVal (Tag t) = tag (fromAtom t)
+pVal (Var (V i) t)
+    | TyPtr _ <- t = char 'p' <> tshow i
+    | TyNode <- t = char 'n' <> tshow i
+    | t == Ty cChar = char 'c' <> tshow i
+    | t == tIntzh  = char 'i' <> tshow i
+    | Ty _ <- t  = char 'l' <> tshow i
+    | TyTag <- t  = char 't' <> tshow i
+pVal (Var (V i) _) = char 'v' <> tshow i
+pVal (Lit i t) | t == tCharzh, i >= 0x20 && i < 0x7f, Just x <- toIntegral i = tshow (chr x)
+pVal (Lit i _)  = tshow i
+--pVal Unit = text "()"
+pVal (Tup xs)  = tupled $ map pVal xs
+pVal (Const v) = char '&' <> pVal v 
+pVal (Addr _) = text "<ref>"
+
+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,(Tup as :-> e)) = func (fromAtom n) <+> hsep (map pVal as) <+> operator "=" <+> keyword "do" <$> indent 2 (prettyExp empty e)
+
+
+printGrin :: Grin -> IO ()
+printGrin Grin { grinFunctions = ds', grinCafs = cafs } = do
+    when (not $ null cafs) $ do 
+        putErrLn "-- Cafs"
+        mapM_ (putErrLn) $ map (\(x,y) -> show x ++ " = " ++  render (prettyVal y))  cafs 
+    putErrLn "-- Functions"
+    mapM_ (putErrLn . render) $ map prettyFun ds'
+
addfile ./Grin/Show.hs-boot
hunk ./Grin/Show.hs-boot 1
+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
addfile ./Grin/Simplify.hs
hunk ./Grin/Simplify.hs 1
+module Grin.Simplify(simplify) where
+
+import Grin.Grin
+import Grin.Whiz
+import Control.Monad.State
+import Stats
+import Data.Map as Map
+import Data.Set as Set
+import FreeVars
+import Data.Monoid
+import MonoidUtil()
+import DDataUtil()
+import List
+import Atom
+import GenUtil
+import Control.Monad.Identity
+
+-- perform a number of simple simplifications. 
+-- inline very small and builtin-wrapper functions
+-- copy propegation
+-- CSE / constant propegation
+-- dispose of code unreachable via Error
+
+import Control.Monad.State
+import Control.Monad.Trans
+
+at_OptSimplifyInline  = toAtom "Optimize.simplify.inline"
+at_OptSimplifyCopyProp  = toAtom "Optimize.simplify.copy-propagate"
+at_OptSimplifyNodeReduction  = toAtom "Optimize.simplify.node-reduction"
+at_OptSimplifyDeadVar  = toAtom "Optimize.simplify.dead-var"
+at_OptSimplifyTrivialCase  = toAtom "Optimize.simplify.trivial-case"
+at_OptSimplifyBadAssignment  = toAtom "Optimize.simplify.bad-assignment"
+
+
+simplify :: Stats -> Grin -> IO Grin
+simplify stats grin = do
+    gfn <- sequence [  do (x,_) <- (evalStateT (whiz fn gv f whizState l) mempty ); return (n,x) |  (n,l) <- grinFunctions grin]
+    deadVars stats  grin { grinFunctions = gfn }
+    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
+        inline 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 (Tup xs,Return (Tup xs'))
+    gv (NodeC t xs,Return (NodeC t' xs')) | t /= t' = do 
+            lift $ tick stats at_OptSimplifyBadAssignment
+            gv (NodeC t xs,Error ("Bad Assignment: " ++ show (t,t')) TyNode)
+    gv (p,e) = do
+        (env,_) <- get 
+        e <- (applySubstE env e)
+        case e of
+            Return v | Just n <- varBind grin p v -> do
+                lift $ tick stats at_OptSimplifyCopyProp
+                modify (`mappend` (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 l <- Map.lookup fn funcMap = do
+            lift $ tick stats at_OptSimplifyInline -- (toAtom $ fromAtom at_OptSimplifyInline ++ "." ++ fromAtom fn)
+            return $ Return (Tup 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 ev _)) | ev == funcEval = return $ Map.single app (Return b)  
+    --getCS (b,app@(App ev _)) | ev == funcApply = return $ Map.single app (Return b)  
+    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]) (Return v)     -- TODO - only works if node stores have always been evaluated. 
+    getCS (b@Var {},Store v@(NodeC t _)) | tagIsWHNF t, t /= tagHole = return $ Map.fromList [(Store v,Return b),(Fetch b,Return v),(App funcEval [b],Return v)]  
+    getCS (b@Var {},Store v@(NodeC t _)) | t /= tagHole = return $ Map.fromList [(Store v,Return b)]  
+    getCS (b@Var {},Return (Const v)) = return $ Map.fromList [(Fetch b,Return v),(App funcEval [b],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
+
+cseStat n = toAtom $ "Optimize.simplify.cse." ++ g n where
+    g (App n _) = fromAtom n
+    g Fetch {} = "Fetch"
+    g Store {} = "Store"
+    g _ = "Misc"
+
+varBind :: Monad m => Grin -> Val -> Val -> m (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 _ Unit Unit = return mempty
+varBind grin (Tup xs) (Tup ys) | length xs == length ys  = liftM mconcat $ sequence $  zipWith (varBind grin) xs ys
+varBind _ (Tag i) (Tag i') | i == i' = return mempty
+--varBind (NodeV v vs) (NodeV t vs') = do 
+--    be <- sequence $  zipWith varBind vs vs' 
+--    b <- varBind v t
+--    return (mconcat $ b:be)
+varBind grin (NodeC t vs) (NodeC t' vs') | t == t' = do 
+    liftM mconcat $ sequence $  zipWith (varBind grin) vs vs' 
+varBind grin v r  | runIdentity (typecheck (grinTypeEnv grin) v) == runIdentity (typecheck (grinTypeEnv grin) r)  = fail "unvarBindable"    -- check type to be sure
+varBind _ x y = error $ "varBind: " ++ show (x,y)
+
+isSimple :: (Atom,Lam) -> Bool
+isSimple (fn,x) = f (3::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 _ (_ :-> App fn' _) | fn == fn' = False
+    f _ _ = True
+
+    {-
+
+isSimple :: (Atom,Lam) -> Bool
+isSimple (fn,_ :-> x) = f x where
+ f x| App fn' _ <- x , fn /= fn' = True 
+    | Return {} <- x = True
+    | Fetch {}  <- x = True
+    | Store {}  <- x = True
+    | Prim {}   <- x = True
+    | Error {}  <- x = True
+    | Cast {}   <- x = True
+    | Update {} <- x = True
+    | z :>>= _ :-> Return {} <- x = f z 
+    | Return {} :>>= _ :-> z <- x = f z 
+    | Fetch {} :>>= _ :-> z <- x = f z 
+    | Store {} :>>= _ :-> z <- x = f z 
+    | Prim {} :>>= _ :-> z <- x = f z 
+    | Update {} :>>= _ :-> z <- x = f z 
+    | z :>>= _ :-> Error {} <- x = f z 
+    | Cast {} :>>= _ :-> z <- x = f z 
+    | z :>>= _ :-> Cast {} <- x = f z 
+    | otherwise = False
+    -}
+
+
+deadVars :: Stats -> Grin -> IO Grin
+deadVars stats grin = do
+    gfn <- sequence [  do (x,_) <- (evalStateT (fizz (grinTypeEnv grin) fn gv f whizState l) (mempty :: Set.Set Var) ); return (n,x) |  (n,l) <- grinFunctions grin]
+    return $ grin { grinFunctions =  gfn }
+    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)) 
+        return (Just w)
+    gv w@(_,e) = f e >> return (Just w)
+
+
+isOmittable (Fetch {}) = True
+isOmittable (Return {}) = True
+isOmittable (Store {}) = True
+isOmittable (Cast {}) = True
+isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]
+isOmittable _ = False
+
addfile ./Grin/Val.hs
hunk ./Grin/Val.hs 1
+module Grin.Val(FromVal(..),ToVal(..),cChar,cInt,world__,pworld__) where
+
+import Grin.Grin
+import Atom
+import Char
+import VConsts 
+import Number
+
+nil = (toAtom "CPrelude.[]")
+cons =  (toAtom "CPrelude.:")
+
+cChar = toAtom "CPrelude.Char"
+cInt = toAtom "CPrelude.Int"
+
+world__ = NodeC (toAtom "CJhc.IO.World__") []
+pworld__ = Const world__
+
+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 () where
+    toVal () = vUnit
+    toUnVal () = unit
+
+instance ToVal Bool where
+    toVal True = vTrue
+    toVal False = vFalse
+
+instance ToVal Ordering where
+    toVal x = vOrdering x
+
+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 (toAtom "CPrelude.(,)") [x,y] 
+
+instance ToVal Char where
+    toVal c = NodeC cChar [toUnVal c]
+    toUnVal c =   Lit (fromIntegral $ ord c) (Ty cChar)
+instance ToVal Int where
+    toVal c = NodeC (toAtom "CPredule.Int") [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 = return (chr x)
+    fromVal n = fail $ "Val is not Char: " ++ show n
+    fromUnVal (Lit i _) | Just x <- toIntegral i = return (chr x)
+    fromUnVal n = fail $ "Val is not UnChar: " ++ show n 
+instance FromVal () where
+    fromVal n | n == toVal () = return ()
+    fromVal n = fail $ "Val is not (): " ++ show n
+    fromUnVal (Tup []) = return ()
+    fromUnVal n = fail $ "Val is not Un(): " ++ 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
addfile ./Grin/Whiz.hs
hunk ./Grin/Whiz.hs 1
+module Grin.Whiz(whiz, fizz, whizState, normalizeGrin,normalizeGrin', applySubstE, applySubst, whizExps) where
+
+import Grin.Grin
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad.State
+import Control.Monad.Writer
+import Control.Monad.Trans
+import Data.Monoid
+import DDataUtil()
+import Control.Monad.Identity
+
+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@Grin { grinFunctions = fs } = grin { grinFunctions = f fs [] (Right 1) } where
+    f [] xs _ = reverse xs
+    f ((a,lm):xs) ys set = f xs ((a,lm'):ys) set' where
+        (Identity (lm',set')) = fizz (grinTypeEnv grin) (\_ x -> x) (return . Just) return set lm 
+
+normalizeGrin' :: Grin -> Grin
+normalizeGrin' grin@Grin { grinFunctions = fs } = grin { grinFunctions = f fs [] } 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 (Tup xs@(_:_))) ((senv,p@(Tup ys@(_:_)),b):rs) env | length xs == length ys  = do
+        Return (Tup xs) <- g env a 
+        (Tup 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 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 => 
+    TyEnv -> 
+    (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 tyEnv 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 (Tup xs@(_:_))) ((senv,p@(Tup ys@(_:_)),b):rs) env | length xs == length ys  = do
+        Return (Tup xs) <- g env a 
+        (Tup 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 a@(Error msg ty) ((senv,p,b):xs) env = do
+        lift $ tf (Error msg (runIdentity $ tc tyEnv b))
+    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 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 = f x where 
+    g = applySubst env
+    f (App a vs) = do
+        vs' <- mapM g vs
+        return $ App a vs'
+    f (Return v) = do
+        v <- g v
+        return $ Return v
+    f (Prim x vs) = do
+        vs <- mapM g vs
+        return $ Prim x vs
+    f (Store v) = do
+        v <- g v
+        return $ Store v
+    f (Fetch v) = do
+        v <- g v
+        return $ Fetch v
+    f (Update a b) = do
+        a <- g a
+        b <- g b
+        return $ Update a b
+    f e@Error {} = return e
+    f (Cast v t) = do 
+        v <- g v
+        return $ Cast v t
+    f (Case e as) = do 
+        e <- g e
+        return $ Case e as
+    f x = error $ "applySubstE: " ++ show x
+
+applySubst env x = f x where
+    f (Var v _) | Just n <- Map.lookup v env =  return n
+    f (NodeC t vs) = do
+        vs' <- mapM f vs
+        return $ NodeC t vs'
+    f (Tup vs) = do
+        vs' <- mapM f vs
+        return $ Tup vs'
+    f (NodeV t vs) | Just (Var t' _) <- Map.lookup t env = do
+        vs' <- mapM f vs
+        return $ NodeV t' vs'
+    f (NodeV t vs) = do
+        vs' <- mapM f vs
+        return $ NodeV t vs'
+    f Addr {} = error "Address in subst" 
+    f x = return x
+
+renamePattern :: MonadState (WhizState) m => Val ->  m (Val,WhizEnv) 
+renamePattern x = runWriterT (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 (Tup vs) = do
+        vs' <- mapM f vs
+        return $ Tup vs'
+    f (NodeV t vs) = do
+        t' <- lift $ newVarName t
+        tell (Map.singleton t (Var t' TyTag))
+        vs' <- mapM f vs
+        return $ NodeV t' vs'
+    f Addr {} = error "Address in pattern" 
+    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
+    
+
+
addfile ./HasSize.hs
hunk ./HasSize.hs 1
+
+module HasSize where
+
+import qualified Data.Map(Map,size)
+import qualified Data.Set(Set,size)
+import qualified Data.IntMap(IntMap,size)
+import qualified Data.IntSet(IntSet,size)
+
+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 . HasSize.size  
+
+instance HasSize [x] where
+    size = length
+    sizeEQ 0 [] = True
+    sizeEQ _ [] = False
+    sizeEQ 0 _ = False
+    sizeEQ n (_:xs) = sizeEQ (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
+
+
addfile ./Ho.hs
hunk ./Ho.hs 1
+module Ho(Ho(..),HoHeader(..),FileDep(..),findModule,showHoCounts,initialHo,dumpHoFile) where
+
+
+import Prelude hiding(print,putStrLn)
+import System.IO hiding(print,putStrLn)
+import Atom
+import Binary
+import CharIO
+import Class
+import Control.Monad.Identity
+import DataConstructors
+import Data.Graph(stronglyConnComp,SCC(..))
+import Data.IORef
+import Data.Monoid
+import Doc.DocLike
+import E.E 
+import qualified PPrint(render)
+import E.Rules
+import FrontEnd.Infix
+import FrontEnd.Unlit
+import GenUtil hiding(putErrLn,putErr,putErrDie)
+import FrontEnd.ParseMonad
+import FrontEnd.HsParser
+import HsSyn
+import KindInfer
+import List
+import MapBinaryInstance()
+import Doc.Pretty
+import Monad
+import Name
+import Options
+import PackedString
+import PrimitiveOperators
+import qualified FlagDump as FD
+import qualified Data.Map as Map
+import Representation
+import System.Posix.Files
+import System.Posix.IO
+import TypeSynonyms
+import Warning
+import Doc.PPrint
+import Directory
+import Maybe
+import IO(bracket)
+import E.Subst(substMap'')
+import E.Inline(emapE)
+
+
+version :: Int
+version = 5
+
+magic = (packString "jhc Haskell Object File",version)
+magic2 = packString "John's Haskell Compiler"
+
+
+shortenPath :: String -> IO String
+shortenPath x@('/':_) = do
+    cd <- getCurrentDirectory
+    pwd <- lookupEnv "PWD"
+    h <- lookupEnv "HOME"
+    --print (x,cd,h)
+    let f d = d >>= \d -> getPrefix d x >>= \ ('/':rest) -> return rest
+    return $ fromJust $ getPrefix cd x `mplus` f pwd `mplus` liftM ("~/" ++) (f h) `mplus` return x 
+shortenPath x = return x
+            
+
+data HoHeader = HoHeader {
+    hohGeneration :: Int,
+    hohDepends :: [FileDep],            -- ^ Haskell Source files depended on
+    hohModDepends :: [(Module,FileDep)] -- ^ Other objects depended on
+    }
+    {-! derive: GhcBinary !-}
+
+data Ho = Ho {
+    -- filled in by front end
+    hoModules :: Map.Map Module FileDep,     -- ^ Map of module to ho file, This never actually ends up in the binary file on disk, but is filled in when the file is read.
+    hoExports :: Map.Map Module [Name], 
+    hoDefs :: Map.Map Name (SrcLoc,[Name]),
+    hoAssumps :: Map.Map Name Scheme,        -- used for typechecking 
+    hoFixities :: FixityMap,
+    hoKinds :: KindEnv,                      -- used for typechecking
+    hoClassHierarchy :: ClassHierarchy,
+    hoTypeSynonyms :: TypeSynonyms,
+    hoProps :: Map.Map Name [Atom],
+    -- Filled in by E generation
+    hoDataTable :: DataTable,
+    hoEs :: Map.Map Name (TVr,E), 
+    hoRules :: Rules
+    }
+    {-! derive: GhcBinary, Monoid !-}
+
+                      
+-- | Contains hopefully enough meta-info to uniquely identify a file
+-- independent of its name.
+
+data FileDep = FileDep {
+    fileName :: Atom,
+    fileModifyTime :: Int,
+    fileDeviceID :: Atom,
+    fileFileID :: Int,
+    fileFileSize :: Int
+    } deriving(Show)
+    {-! derive: GhcBinary !-}
+
+emptyFileDep = FileDep mempty 0 mempty 0 0
+
+instance Eq FileDep where
+    a == b = map ($ a) fs == map ($ b) fs && fileDeviceID a == fileDeviceID b where 
+        fs = [fileModifyTime,fileFileID,fileFileSize]
+
+instance DocLike d => PPrint d FileDep where 
+    pprint fd = tshow (fileName fd) <> char ':' <+> tshow (fileModifyTime fd) 
+
+toFileDep fn fs = FileDep { 
+    fileName = toAtom fn 
+    ,fileModifyTime = fromEnum (modificationTime fs) 
+    ,fileDeviceID = toAtom $ show (deviceID fs) 
+    ,fileFileID = fromIntegral (fileID fs) 
+    ,fileFileSize = fromIntegral (fileSize fs) 
+    }
+
+findFirstFile :: String -> [(String,a)] -> IO (Handle,FileDep,a) 
+findFirstFile err [] = Warning.err "missing-dep" ("Module not found: " ++ err) >> return (undefined,emptyFileDep,undefined)
+findFirstFile err ((x,a):xs) = flip catch (\e ->   findFirstFile err xs) $ do
+    (fh,fd) <- openGetFileDep x
+    return (fh,fd,a)
+    
+
+
+findModule :: Ho                                 -- ^ Accumulated Ho
+              -> (Either Module String)          -- ^ Either a module or filename to find
+              -> (Ho -> [HsModule] -> IO Ho)     -- ^ Process set of mutually recursive modules to produce final Ho 
+              -> IO Ho                           -- ^ Final accumulated ho
+findModule have (Left m) _ | m `Map.member` (hoExports have) = return have
+findModule have need func  = do 
+    let f (Left (Module m)) = (m,searchPaths m)
+        f (Right n) = (n,[(n,reverse $ 'o':'h':dropWhile (/= '.') (reverse n))])
+        (name,files) = f need
+    (ho,ms) <- Ho.getModule have name files
+    processIOErrors
+    let scc = map f $  stronglyConnComp [ (x,fromModule $ hsModuleName hs,hsModuleRequires hs) | x@(hs,fd,honm) <- ms ] 
+        f (AcyclicSCC x) = [x]
+        f (CyclicSCC xs) = xs
+    when (dump FD.SccModules) $ CharIO.putErrLn $ "scc modules:\n" ++ unlines ( map  (\xs -> show [ hsModuleName x | (x,y,z) <- xs ]) scc)
+    let f ho [] = return ho
+        f ho (sc:scs) = do
+            ho' <- func ho [ hs | (hs,_,_) <- sc ]
+            let mods = [ hsModuleName hs | (hs,_,_) <- sc ]
+                mods' = [ Module m  | (hs,_,_) <- sc, m <- hsModuleRequires hs, Module m `notElem` mods]
+                mdeps = [ (m,runIdentity $ Map.lookup m (hoModules ho)) | m <- mods'] 
+            ho' <- recordHoFile ho' [ x | (_,_,x) <- sc ] HoHeader { hohGeneration = 0, hohDepends = [ x | (_,x,_) <- sc], hohModDepends = mdeps }
+            f (ho `mappend` ho') scs 
+    f (ho `mappend` have) scc 
+
+checkForHoFile :: String            -- ^ file name to check for
+    -> IO (Maybe (HoHeader,Ho))
+checkForHoFile fn = flip catch (\e -> putErrLn (show e) >> return Nothing) $ do
+    bracket (openGetFileDep fn) (hClose . fst) $ \ (fh,dep) -> do 
+    -- (fh,dep) <- openGetFileDep fn
+    if optIgnoreHo options then do
+        wdump FD.Progress $ do
+            fn' <- shortenPath fn
+            putErrLn $ "Skipping haskell object file:" <+> fn'
+        return Nothing 
+     else do 
+    --wdump FD.Progress $ do
+    --    putErrLn $ "Found haskell object file:" <+> fn
+    bh <- openBinIO fh
+    x <- get bh
+    if x /= magic then (putErrLn $ "Bad ho file:" <+> fn)  >> return Nothing else do 
+    hh <- get bh
+    xs <- mapM checkDep (hohDepends hh)
+    if not (and xs) then  return Nothing else do
+        ho <- get bh 
+        x <- get bh
+        if x /= magic2 then (putErrLn $ "Bad ho file:" <+> fn)  >>  return Nothing else do 
+        wdump FD.Progress $ do
+            fn' <- shortenPath fn
+            putErrLn $ "Found object file:" <+> fn'
+        return $ Just (hh,ho { hoModules = fmap (const dep) (hoExports ho) })
+
+checkDep fd = do
+    fs <- getFileStatus (fromAtom $ fileName fd)
+    return (fd == toFileDep (fileName fd) fs)
+     
+
+-- | This reads in an entire ho file for diagnostic purposes.
+readHoFile :: String -> IO (HoHeader,Ho)  
+readHoFile fn = do
+    fh <- openBinaryFile fn ReadMode
+    bh <- openBinIO fh
+    x <- get bh
+    when (x /= magic) (putErrDie $ "Bad ho file magic1:" <+> fn)  
+    hh <- get bh 
+    ho <- get bh 
+    x <- get bh 
+    when (x /= magic2) (putErrDie $ "Bad ho file magic2:" <+> fn)  
+    return (hh,ho)
+    
+
+{-# NOINLINE dumpHoFile #-}
+dumpHoFile :: String -> IO ()
+dumpHoFile fn = do
+    (hoh,ho) <- readHoFile fn 
+    putStrLn fn 
+    putStrLn $ "Generation:" <+> tshow (hohGeneration hoh)
+    putStrLn $ "Dependencies:" <+>  pprint (sortUnder (show . fileName) $ hohDepends hoh)
+    putStrLn $ "ModDependencies:" <+>  pprint (sortUnder fst $ hohModDepends hoh)
+    putStrLn $ "hoMods:" <+> tshow (map fromModule $ Map.keys $  hoExports ho)
+    putStrLn $ "hoExports:" <+> tshow (size $ hoExports ho)
+    putStrLn $ "hoDefs:" <+> tshow (size $ hoDefs ho)
+    putStrLn $ "hoAssumps:" <+> tshow (Map.size $ hoAssumps ho)
+    --putErrLn $ "hoAssumps:" <+> vcat (map show $ Map.keys $ hoAssumps ho)
+    putStrLn $ "hoFixities:" <+> tshow (size $  hoFixities ho)
+    putStrLn $ "hoKinds:" <+> tshow (size $  hoKinds ho)
+    putStrLn $ "hoClassHierarchy:" <+> tshow (size $  hoClassHierarchy ho)
+    putStrLn $ "hoTypeSynonyms:" <+> tshow (size $  hoTypeSynonyms ho)
+    putStrLn $ "hoDataTable:" <+> tshow (size $  hoDataTable ho)
+    putStrLn $ "hoEs:" <+> tshow (size $  hoEs ho)
+    putStrLn $ "hoProps:" <+> tshow (size $  hoProps ho)
+    putStrLn $ "hoRules:" <+> tshow (size $  hoRules ho)
+    when (dump FD.Kind) $ do 
+        putStrLn " \n ---- kind information ---- \n";
+        CharIO.putStrLn $  (pprint $ hoKinds ho :: String) -- pprintEnvMap kindInfo}
+    when (dump FD.ClassSummary) $ do
+        putStrLn "  ---- class summary ---- "
+        printClassSummary (hoClassHierarchy ho)
+    when (dump FD.Class) $
+         do {putStrLn "  ---- class hierarchy ---- ";
+             printClassHierarchy (hoClassHierarchy ho)}
+    when (dump FD.Rules) $ do 
+        putStrLn "  ---- rules ---- "
+        printRules (hoRules ho)
+    wdump FD.Datatable $ do
+         putStrLn "  ---- data table ---- "
+         putDocM CharIO.putStr (showDataTable (hoDataTable ho))
+         putChar '\n'
+    wdump FD.Types $ do
+        putStrLn " ---- the types of identifiers ---- "
+        putStrLn $ PPrint.render $ pprint (hoAssumps ho) 
+        
+
+
+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]
+    
+--recordHoFile :: Ho -> [(HsModule,FileDep,String,[FileDep])] -> [FileDep] -> IO [FileDep]
+ 
+recordHoFile :: 
+    Ho               -- ^ File to record
+    -> [String]      -- ^ files to write to
+    -> HoHeader      -- ^ file header
+    -> IO Ho         -- ^ Ho updated with this recordfiel dependencies
+recordHoFile ho fs header = do
+    if optNoWriteHo options then do
+        wdump FD.Progress $ do
+            fs' <- mapM shortenPath fs
+            putErrLn $ "Skipping Writing Ho Files: " ++ show fs' 
+        return (ho { hoModules = fmap (const emptyFileDep) (hoExports ho) })
+      else do
+    --let header = HoHeader { hohGeneration = 0, hohDepends = snub (fd ++ concat [ hsdep:ds | (hs,hsdep,honm,ds) <- sc] )}
+    let removeLink' fn = catch  (removeLink fn)  (\_ -> return ())
+    let g (fn:fs) = do
+            fd <- f fn
+            mapM_ (l fn) fs 
+            return fd
+        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 emptyFileDep else do
+            let tfn = fn ++ ".tmp"
+            fh <- openBinaryFile tfn WriteMode
+            bh <- openBinIO fh
+            put bh magic
+            put bh header 
+            put bh (mapHoBodies eraseE ho { hoModules = mempty })
+            put bh magic2
+            (fh,fd) <- hGetFileDep fn fh
+            hClose fh
+            rename tfn fn
+            return fd
+    dep <- g fs
+    return (ho { hoModules = fmap (const dep) (hoExports ho) })
+    --return [ hsdep | (hs,hsdep,honm,ds) <- sc]
+
+
+
+-- | Find a module, returning the combined up to date Ho files and the parsed
+-- contents of files that still need to be processed, This chases dependencies so 
+-- you could end up getting parsed source for several files back.
+-- We only look for ho files where there is a cooresponding haskell source file.
+
+getModule :: 
+    Ho          -- ^ Current set of modules, we assume anything in here is prefered to what is found on disk.
+    -> String   -- ^ Module name for printing error messages 
+    -> [(String,String)]  -- ^ files to search, and the cooresponding ho file
+    -> IO (Ho,[(HsModule,FileDep,String)])
+getModule ho name files  = do         
+    ho_ref <- newIORef ho
+    fixup_ref <- newIORef (getFixups ho)
+    need_ref <- newIORef []
+    let loop name files  = do
+            --wdump FD.Progress $ do
+            --    putErrLn $ "Looking for :" <+> name <+> "at" <+> show files
+            -- First find the haskell source file.
+            (fh,fd,ho_name) <- findFirstFile name files 
+            --if fd == emptyFileDep then return mempty else do
+            when (fd == emptyFileDep) $ processIOErrors >> fail "Couldn't find file" -- then return mempty else do
+            mho <- checkForHoFile ho_name 
+            case mho of 
+                Just (hh,ho') -> do 
+                    as <- mapM checkHoDep (hohModDepends hh) 
+                    case and as of
+                        True -> do 
+                            fixups <- readIORef fixup_ref 
+                            let nfixups = getFixups ho' `mappend` fixups
+                            writeIORef fixup_ref nfixups
+                            modifyIORef ho_ref (applyFixups nfixups ho' `mappend`) >> hClose fh 
+                        False -> addNeed name fd fh ho_name 
+                Nothing -> addNeed name fd fh ho_name
+        checkHoDep :: (Module,FileDep) -> IO Bool
+        checkHoDep (m,fd) = do
+            --wdump FD.Progress $ do
+            --    putErrLn $ "checking dependency:" <+> show m <+> "at" <+> fromAtom (fileName fd) 
+            ho <- readIORef ho_ref
+            case Map.lookup m (hoModules ho) of
+                Just fd' | fd == fd' -> return True
+                Just fd' | fd /= emptyFileDep -> do
+                    wdump FD.Progress $ do
+                        putErrLn $ "Found newer dependency:" <+> fromModule m <+> "at" <+> pprint (fd,fd')
+                    return False
+                Just _ -> return False
+                Nothing -> do
+                    xs <- readIORef need_ref
+                    case lookup m xs of 
+                        Just _ -> return False
+                        Nothing -> loop (fromModule m) (searchPaths (fromModule m)) >> checkHoDep (m,fd)
+        addNeed :: String -> FileDep -> Handle -> String ->  IO ()
+        addNeed name fd fh ho_name = do
+            cs <- CharIO.hGetContents fh
+            hs <- parseHsSource (fromAtom $ fileName fd) cs
+            wdump FD.Progress $ do
+                sp <- shortenPath $ fromAtom (fileName fd)
+                putErrLn $ "Found dependency:" <+> name <+> "at" <+> sp -- fromAtom (fileName fd) --  <+> show (hsModuleRequires hs)
+            modifyIORef need_ref $ ((hsModuleName hs,(hs,fd,ho_name)):) 
+            mapM_ (checkHoDep . (flip (,) emptyFileDep) . Module) $ hsModuleRequires hs
+    loop name files
+    ho   <- readIORef ho_ref
+    need <- readIORef need_ref
+    return (ho,snds need)
+
+hsModuleRequires x = ans where
+    noPrelude =   or $ not (optPrelude options):[ opt == c | opt <- hsModuleOptions x, c <- ["-N","--noprelude"]] 
+    ans = snub $ (if noPrelude then id else  ("Prelude":)) [ fromModule $ 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]
+
+ 
+parseHsSource :: String -> String -> IO HsModule
+--parseHsSource fn s = case parse s' (SrcLoc fn 1 1) 0 [] of
+parseHsSource fn s = case runParserWithMode ParseMode { parseFilename = fn } parse  s'  of
+                      ParseOk e -> return e 
+                      ParseFailed sl err -> putErrDie $ show sl ++ ": " ++ err 
+    where 
+    s' = if "shl." `isPrefixOf` reverse fn  then unlit fn s else s
+                      -- warnF fn "parse-error" err >> return emptyHsModule
+
+
+mapHoBodies  :: (E -> E) -> Ho -> Ho
+mapHoBodies sm ho = ho { hoEs = Map.map f (hoEs ho) , hoRules =  E.Rules.mapBodies ( sm) (hoRules ho) } where
+    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
+
+getFixups :: Ho -> Map.Map Int E
+getFixups ho = Map.fromList [ (tvrIdent x,EVar x) | (x,_) <- Map.elems (hoEs ho)]  
+
+applyFixups :: Map.Map Int E -> Ho -> Ho
+applyFixups mie ho = ho { hoEs = Map.map f (hoEs ho) , hoRules =  E.Rules.mapBodies (sm) (hoRules ho) } where
+    f (t,e) = (t,sm e)  
+    sm = substMap'' mie 
+
+
+
+
+{-
+emptyHsModule = HsModule {
+    hsModuleName = Module "@invalid",
+    hsModuleImports = [],
+    hsModuleExports = Nothing,
+    hsModuleDecls = [],
+    hsModuleOptions = []
+    }
+-}
+
+hGetFileDep fn fh = do
+    fd <- handleToFd fh
+    fs <- getFdStatus fd
+    fh <- fdToHandle fd
+    return (fh,toFileDep fn fs)
+    
+
+openGetFileDep fn = do
+    (fh,fs) <- openGetStatus fn
+    return (fh,toFileDep fn fs)
+
+openGetStatus fn = do 
+    fh <- openBinaryFile fn ReadMode
+    fd <- handleToFd fh
+    fs <- getFdStatus fd
+    fh <- fdToHandle fd
+    return (fh,fs)
+                      
+    
+showHoCounts ho = do
+    putErrLn $ "hoMods:" <+> tshow (map fromModule $ Map.keys $  hoExports ho)
+    putErrLn $ "hoExports:" <+> tshow (size $ hoExports ho)
+    putErrLn $ "hoDefs:" <+> tshow (size $ hoDefs ho)
+    putErrLn $ "hoAssumps:" <+> vcat (map show $ Map.keys $ hoAssumps ho)
+    putErrLn $ "hoFixities:" <+> tshow (size $  hoFixities ho)
+    putErrLn $ "hoKinds:" <+> tshow (size $  hoKinds ho)
+    putErrLn $ "hoClassHierarchy:" <+> tshow (size $  hoClassHierarchy ho)
+    putErrLn $ "hoTypeSynonyms:" <+> tshow (size $  hoTypeSynonyms ho)
+    putErrLn $ "hoDataTable:" <+> tshow (size $  hoDataTable ho)
+    putErrLn $ "hoEs:" <+> tshow (size $  hoEs ho)
+    putErrLn $ "hoProps:" <+> tshow (size $  hoProps ho)
+    putErrLn $ "hoRules:" <+> tshow (size $  hoRules ho)
+
+
+initialHo = mempty { hoEs = es , hoClassHierarchy = ch  }  where
+    ch = foldl addOneInstanceToHierarchy mempty (map ((,) False) primitiveInsts)
+    es = Map.fromList [  (n,(tVr (atomIndex $ toAtom n) (typ v),v)) |  (n,v) <- constantMethods ] `mappend` es'
+    es' = Map.fromList [ (n,(tVr (atomIndex $ toAtom n) (typ v),v)) | (n,t,p,d) <- theMethods, let v = f n t p d  ]
+    f _ _ _ _ = error "f no longer relevant"
+
+
+
+
+
+    {-
+    f n t p d = ans where
+        (r':as') = reverse t
+        r = tt r'
+        as = map tt (reverse as')
+        tt 'a' = ELit (LitCons (parseName TypeConstructor d) [] eStar)
+        tt 'B' = tBool 
+        tt 'I' = tInt
+        tvs = [  (TVr i a) | a <- as | i <- [ 2,4 ..]]
+        ans = foldr ELam (EPrim (primPrim p) (map EVar tvs) r) tvs
+      -}  
+
+
+
+    
+    {-
+
+    -- Collect all complete 'ho' files and parsed code we need to compile
+--getModule :: Set.Set String -> String -> [(String,String)] -> IO (Ho,[],[FileDep])
+getModule ws name files = do
+    --wdump FD.Progress $ do
+    --    putErrLn $ "getModule:" <+> tshow ws <+> tshow name <+> tshow files
+    (c,fd,honm) <- findFirstFile name files  
+    if fd == emptyFileDep then return (mempty,mempty,mempty) else do 
+    ho <- checkForHoFile honm
+    case ho of
+        Just (ds,ho) -> mapM_ (\x -> modifyIORef ws (Set.insert x)) (Map.keys $ hoExports ho) >> return (ho,mempty,ds)
+        Nothing -> do
+            hs <- parseHsSource (fromAtom $ fileName fd) c
+            wdump FD.Progress $ do
+                putErrLn $ "Found dependency:" <+> name <+> "at" <+> fromAtom (fileName fd)  <+> show (hsModuleRequires hs)
+            --print hs
+            modifyIORef ws $ Set.insert ( hsModuleName hs) 
+            ws' <- readIORef ws
+            --mapM_ (modifyIORef ws) [Set.insert (Module x) | x <- hsModuleRequires hs] 
+            let f x = do
+                ws' <- readIORef ws
+                case Module x `Set.member` ws' of
+                    True ->  return (mempty,mempty,mempty)
+                    False -> Ho.getModule ws x (searchPaths x) 
+                --f x | Module x `Set.member` ws' = return (mempty,mempty,mempty)
+                --    | otherwise = Ho.getModule ws x (searchPaths x) 
+            xs <- mapM f (hsModuleRequires hs) 
+            let x@(_,_,ds) = mconcat xs 
+            return $ mconcat [(mempty,[(hs,fd,honm,ds)],mempty),x] 
+            
+            -}
addfile ./Info.hs
hunk ./Info.hs 1
+module Info where
+
+import Data.Dynamic
+import Data.Monoid
+import Data.Generics
+import HasSize
+import Monad
+import qualified Data.Set as Set
+
+-- extensible type indexed product
+
+type T = Info
+
+newtype Info = Info [Dynamic]
+    deriving(HasSize,Typeable)
+
+instance Data Info where
+    toConstr = undefined
+
+instance Monoid Info where
+    mempty = Info []
+    mappend (Info as) (Info bs) = Info ([ b | b <- bs, not (show b `Set.member` bss) ] ++ as) where
+        bss = Set.fromList $ map show bs 
+
+
+lookup :: forall a m .  (Monad m,Typeable a) => Info -> m a
+lookup (Info ds)  = case msum (map fromDynamic ds) of
+    Just x -> return x
+    Nothing -> fail $ "Info: could not find " ++ show (typeOf (undefined :: a))
+
+insertWith :: (Typeable a) => (a -> a -> a) -> a -> Info -> Info
+insertWith f x (Info ds) = Info (g ds []) where
+    g [] rs = (toDyn x:rs)
+    g (d:ds) rs
+        | Just y <- fromDynamic d = toDyn (f x y):(ds ++ rs)
+        | otherwise = g ds (d:rs)
+
+insert :: (Typeable a) => a -> Info -> Info
+insert x info = insertWith const x info
+
+
+delete :: (Typeable a) => a -> Info -> Info
+delete x info = error "Info.delete"
+
+fetch :: (Monoid a, Typeable a) => Info -> a
+fetch info = maybe mempty id  (Info.lookup info)
+
+extend :: (Monoid a, Typeable a) => a -> Info -> Info
+extend x info = insertWith mappend x info
+
+{-
+
+newtype Info = Info (Map.Map TypeRep Dynamic)
+    deriving(Monoid,HasSize)
+
+
+lookup :: (Monad m,Typeable a) => Info -> m a
+lookup (Info fm) :: m a = case Map.lookup tr fm of
+        Just x -> return (fromDyn x undefined :: a)
+        Nothing -> fail $ "Info: could not find " ++ show tr
+    where tr = typeOf (undefined :: a)
+
+
+fetch :: (Monoid a, Typeable a) => Info -> a
+fetch info = maybe mempty id  (Info.lookup info)
+
+insert :: (Typeable a) => a -> Info -> Info
+insert x (Info fm) = Info (Map.insert (typeOf x) (toDyn x) fm)
+
+insertWith :: (Typeable a) => (a -> a -> a) -> a -> Info -> Info
+insertWith f x (Info fm) = Info (Map.adjust (\y -> toDyn $ f x (fromDyn y undefined)) (typeOf x)  fm)
+
+extend :: (Monoid a, Typeable a) => a -> Info -> Info
+extend x info = insertWith mappend x info
+
+-}
addfile ./Main.hs
hunk ./Main.hs 1
+
+module Main(main) where
+
+import Prelude hiding(putStrLn, putStr,print)
+import Char
+import List hiding(group)
+import Maybe
+
+import C.FromGrin
+import CharIO
+import Class
+import Control.Monad.Identity
+import DataConstructors
+import Data.Monoid
+import Doc.DocLike
+import Doc.PPrint
+import Doc.Pretty
+import qualified E.CPR
+import qualified Info
+import E.Diff
+import E.E
+import E.FromHs
+import E.LambdaLift
+import E.LetFloat
+import E.Pretty
+import E.Rules
+import E.Strictness
+import E.Subst
+import E.Traverse
+import E.TypeCheck
+import FreeVars
+import FrontEnd.FrontEnd
+import GenUtil hiding(replicateM,putErrLn,putErr,putErrDie)
+import GraphUtil
+import Grin.DeadFunctions
+import Grin.FromE
+import Grin.Grin hiding (typecheck)
+import Grin.Show
+import Grin.Whiz
+import Ho
+import HsSyn
+import Name
+import Options
+import qualified Data.IntMap as IM
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified E.SSimplify as SS
+import qualified FlagDump as FD
+import qualified FlagOpts as FO
+import qualified Grin.Interpret
+import qualified Grin.PointsTo
+import qualified Grin.Simplify
+import qualified Stats
+import qualified System
+
+---------------
+-- ∀α∃β . α → β
+---------------
+
+
+printCheckName dataTable e = do
+    putErrLn  ( render $ hang 4 (pprint e <+> text "::") )
+    ty <- typecheck dataTable e
+    putErrLn  ( render $ hang 4 (pprint ty))
+
+
+main = runMain $ do
+    o <- processOptions
+    case optShowHo options of
+        [] -> processFiles  (optArgs o)
+        xs -> mapM_ dumpHoFile xs
+
+processFiles [] | Nothing <- optMainFunc options = do
+    putErrDie "jhc: no input files"
+processFiles [] | Just (b,m) <- optMainFunc options = do
+    m <- return $ parseName Val m
+    Module m <- getModule m
+    stats <- Stats.new
+    me <- parseFiles [] [Module m] (processDecls stats)
+    compileModEnv' stats me
+processFiles  fs = do
+    stats <- Stats.new
+    me <- parseFiles  fs [] (processDecls stats)
+    compileModEnv' stats me
+
+barendregt e = runIdentity  (renameTraverse' e)
+
+processDecls ::
+    Stats.Stats   -- ^ statistics
+    -> Ho   -- ^ Collected ho
+    -> Ho   -- ^ preliminary haskell object  data
+    -> TiData -- ^ front end output
+    -> IO Ho  -- ^ final haskell object file
+processDecls stats ho ho' tiData = do
+    let isExported n | "Instance@" `isPrefixOf` show n = True
+        isExported n = n `Set.member` exports
+        exports = Set.fromList $ concat $ Map.elems (hoExports ho')
+    let decls = concat [ hsModuleDecls  m | (_,m) <- tiDataModules tiData ] ++ Map.elems (tiDataLiftedInstances tiData)
+    let dataTable = toDataTable (Map.fromList $[ (toName TypeConstructor x,y) | (x,y)<- Map.toList (hoKinds ho')] ) (tiAllAssumptions tiData) decls
+    let fullDataTable =  (dataTable `mappend` hoDataTable ho)
+    let allAssumps = (tiAllAssumptions tiData `mappend` hoAssumps ho)
+    ds <- convertDecls (hoClassHierarchy ho') allAssumps  fullDataTable decls
+    wdump FD.Progress $ do
+        putErrLn $ show (length ds) ++ " declarations converted."
+    rules <- createInstanceRules (hoClassHierarchy ho' `mappend` hoClassHierarchy initialHo)   (Map.fromList [ (x,(y,z)) | (x,y,z) <- ds] `mappend` hoEs ho)
+    let allRules = hoRules ho `mappend` rules
+    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
+    let inscope =  [ tvrNum n | (n,_) <- Map.elems $ hoEs ho ] ++ [tvrNum n | (_,n,_) <- ds ] ++ map tvrNum (methodNames (hoClassHierarchy ho `mappend` hoClassHierarchy ho'))
+    let mangle = mangle' (Just $ Set.fromList $ inscope) fullDataTable
+    let doopt' = doopt mangle
+    let f (ds,smap) (n,v,lc) = do
+        wdump FD.Lambdacube $ putErrLn (show n)
+        let g (TVr { tvrIdent = 0 }) = error "absurded zero"
+            g tvr@(TVr { tvrIdent = n, tvrType = k})
+                | sortStarLike k =  tAbsurd k
+                | otherwise = EVar tvr
+        fvs <- return $ foldr IM.delete (freeVars lc)  inscope
+        when (IM.size fvs > 0) $ do
+            putDocM putErr $ parens $ text "Absurded vars:" <+> align (hsep $ map pprint (IM.elems fvs))
+        lc <- mangle False ("Absurdize") (return . substMap (IM.map g fvs)) lc
+        lc <- mangle  False ("Barendregt: " ++ show n) (return . barendregt) lc
+        lc <- mangle  False "deNewtype" (return . deNewtype fullDataTable) lc
+        lc <- doopt' False stats "FixupLets..." (\stats x -> atomizeApps stats x >>= coalesceLets stats)  lc
+        lc <- mangle  False ("Barendregt: " ++ show n) (return . barendregt) lc
+        let cm stats e = do
+            let sopt = mempty { SS.so_exports = inscope, SS.so_boundVars = smap, SS.so_rules = allRules, SS.so_dataTable = dataTable, SS.so_properties = (if fopts FO.InlinePragmas then  hoProps ho else mempty) }
+            let (e',stat,occ) = SS.simplify sopt e
+            Stats.tickStat stats stat
+            return e'
+        lc <- doopt' False stats "Float Inward..." (\stats x -> return (floatInward allRules x))  lc
+        lc <- doopt' False stats "SuperSimplify" cm lc
+        wdump FD.Lambdacube $ printCheckName fullDataTable lc
+        --let bs = annotateBindings mempty lc
+        --mapM_ putErrLn  [ tvrShowName x <+> "->" <+> tshow y | (x,y) <- Map.toList bs]
+        wdump FD.Progress $ putErr "."
+        return ((n,v,lc):ds, Map.insert (tvrNum v) lc smap )
+    let reached = Set.fromList [ tvrNum b | (_,b,_) <- reachable graph  [ tvrNum b | (n,b,_) <- ds, isExported n]]
+        graph =  (newGraph ds (\ (_,b,_) -> tvrNum b) (\ (_,_,c) -> freeVars c))
+        (_,dog)  = findLoopBreakers (const 0) graph
+
+    (ds,_) <- foldM f ([],Map.fromList [ (tvrNum v,e) | (v,e) <- Map.elems (hoEs ho)]) [ x | x@(_,b,_) <- dog, tvrNum b `Set.member` reached ]
+    wdump FD.Progress $ putErrLn "!"
+
+    let ds' = reachable (newGraph ds (\ (_,b,_) -> tvrNum b) (\ (_,_,c) -> freeVars c)) [ tvrNum b | (n,b,_) <- ds, isExported n]
+    wdump FD.Progress $ putErrLn $ "Functions culled: " ++ show (length ds - length ds')
+    wdump FD.OptimizationStats $ Stats.print "Optimization" stats
+    return ho' { hoDataTable = dataTable, hoEs = Map.fromList [ (x,(y,z)) | (x,y,z) <- ds'], hoRules = rules }
+
+
+doopt mangle dmp stats name func lc = do
+    stats' <- Stats.new
+    lc <- mangle dmp name (func stats') lc
+    t' <- Stats.getTicks stats'
+    case t'  of
+        0 -> return lc
+        _ -> do
+            when ((dmp && dump FD.Progress) || dump FD.Pass) $ Stats.print "Optimization" stats'
+            Stats.combine stats stats'
+            doopt mangle dmp stats name func lc
+
+compileModEnv' stats ho = do
+
+    let dataTable = hoDataTable ho
+    let rules = if fopts FO.Rules then hoRules ho else mempty
+    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
+
+    --mapM_ putErrLn ([ show x <+> "::" <+> render (ePretty ty) | (x,(TVr _ ty,_)) <- Map.toList $ hoEs ho])
+    let mainFunc = parseName Val (maybe "Main.main" snd (optMainFunc options))
+    --wdump FD.Progress $ showHoCounts ho
+
+    when (dump FD.ClassSummary) $ do
+        putStrLn "  ---- class summary ---- "
+        printClassSummary (hoClassHierarchy ho)
+    when (dump FD.Class) $ do
+            putStrLn "  ---- class hierarchy ---- "
+            printClassHierarchy (hoClassHierarchy ho)
+    es' <- createMethods dataTable (hoClassHierarchy ho) (hoEs ho)
+    es' <- return [ (x,y,floatInward rules z) | (x,y,z) <- es' ]
+    wdump FD.Class $ do
+        sequence_ [ putDocM CharIO.putErr (pprint $ ELetRec [(y,z)] Unknown) >> putErrLn "" |  (x,y,z) <- es']
+    let es = Map.fromList [ (x,(y,z)) |  (x,y,z) <- es'] `mappend` hoEs ho
+    (_,main,mainv) <- getMainFunction mainFunc es
+    let ds = ((main,mainv):Map.elems es)
+    let ds' = reachable (newGraph ds (tvrNum . fst) (\(t,e) -> freeVars e `mappend` Set.toList (ruleFreeVars rules t)) ) [tvrNum main]
+
+    --wdump FD.Progress $ putErrLn $ "Functions culled: " ++ show (length ds - length ds')
+    let lco = ELetRec ds'  (EVar main)
+    --typecheck dataTable lco
+    wdump FD.Rules $ printRules rules
+    let opt = doopt (mangle dataTable) True stats
+
+    let pe = ePrettyEx
+    --let esimplify = E.Simplify.simplify mempty { so_dataTable = dataTable, so_properties = (if fopts FO.InlinePragmas then  hoProps ho else mempty), so_rules = rules }
+    --let esimplify = E.Simplify.simplify ((if fopts FO.InlinePragmas then  hoProps ho else mempty)) dataTable
+    lc <- mangle dataTable True "Barendregt" (return . barendregt) lco
+    wdump FD.Progress $ printEStats lc
+    let cm stats e = do
+        let sopt = mempty { SS.so_rules = rules, SS.so_dataTable = dataTable, SS.so_properties = (if fopts FO.InlinePragmas then  hoProps ho else mempty) }
+        let (e',stat,occ) = SS.simplify sopt e
+        --let (e'',_,_occ) = collectOcc [] rules dataTable e
+        --mapM_ (putDocMLn CharIO.putErr) $ [ pprint x <+> text "->" <+> tshow y|  (x,y) <- Map.toList occ]
+        --putErrLn ">>> Funzo"
+        --printCheckName dataTable e''
+        Stats.tickStat stats stat
+        return e'
+    lc <- opt "SuperSimplify" cm lc
+
+    -- (lc,_) <- return $ E.CPR.cprAnalyze mempty lc
+    -- sequence_ [ putStrLn $ (tvrShowName t) <+> show (maybe E.CPR.Top id (Info.lookup (tvrInfo t)) ::  E.CPR.Val) | (t,_,_) <- scCombinators $ eToSC dataTable lc ]
+    --lc <- opt "Simplification..." esimplify lc
+    lc <- mangle dataTable True "Barendregt" (return . barendregt) lc
+    --wdump FD.Progress $ printEStats lc
+    lc <- if fopts FO.FloatIn then  opt "Float Inward..." (\stats x -> return (floatInward rules  x))  lc  else return lc
+    --wdump FD.Progress $ printEStats lc
+    --wdump FD.Lambdacube $ printCheckName dataTable lc
+    vs <- collectSolve lc
+    --mapM_ putErrLn $  sort [ tshow x <+> "->" <+> tshow y | (x@(E.Strictness.V i),y@Lam {}) <- vs, odd i]
+    --let esimplify = E.Simplify.simplify mempty { so_dataTable = dataTable, so_properties = (if fopts FO.InlinePragmas then  hoProps ho else mempty), so_rules = rules, so_strictness = Map.fromList [ (i,S n) | (E.Strictness.V i,S n) <- vs] }
+    --lc <- opt "Strictness Simplification..." (\ss e -> esimplify ss e >>= \e' -> printCheckName dataTable e' >> return e' ) lc
+    -- lc <- opt "Strictness Simplification..." esimplify lc
+    let cm stats e = do
+        let sopt = mempty { SS.so_rules = rules, SS.so_dataTable = dataTable, SS.so_properties = (if fopts FO.InlinePragmas then  hoProps ho else mempty), SS.so_strictness = Map.fromList [ (i,S n) | (E.Strictness.V i,S n) <- vs] }
+        let (e',stat,occ) = SS.simplify sopt e
+        Stats.tickStat stats stat
+        return e'
+    lc <- opt "SuperSimplify" cm lc
+
+    wdump FD.LambdacubeBeforeLift $ printCheckName dataTable lc
+    lc <- mangle dataTable True "LambdaLift" (lambdaLiftE stats dataTable) lc
+    lc <- mangle dataTable True  "FixupLets..." (\x -> atomizeApps stats x >>= coalesceLets stats)  lc
+    wdump FD.Lambdacube $ printCheckName dataTable lc
+    wdump FD.OptimizationStats $ Stats.print "Optimization" stats
+    wdump FD.Progress $ printEStats lc
+    wdump FD.Progress $ putErrLn "Converting to Grin..."
+    x <- Grin.FromE.compile dataTable (error "vmap") (eToSC dataTable lc)
+    --Stats.print "Grin" Stats.theStats
+    --wdump FD.GrinPreeval $ printGrin x
+    x <- return $ normalizeGrin x
+    typecheckGrin x
+    let opt x = do
+        wdump FD.Progress $ putErrLn "Optimization Pass..."
+        t <- Stats.getTicks stats
+        x <- deadFunctions True stats [funcMain] x
+        x <- Grin.Simplify.simplify stats x
+        when flint $ typecheckGrin x
+        t' <- Stats.getTicks stats
+        case t == t' of
+            False -> opt x
+            True -> return x
+    x <- opt x
+    wdump FD.OptimizationStats $ Stats.print "Optimization" stats
+    x <- return $ normalizeGrin x
+    typecheckGrin x
+    wdump FD.Progress $ putErrLn "Points-to analysis..."
+    wdump FD.GrinPreeval $ printGrin x
+    x <- Grin.PointsTo.grinInlineEvalApply x
+    typecheckGrin x
+    --wdump FD.Grin $ printGrin x
+    x <- return $ normalizeGrin x
+    typecheckGrin x
+    let opt (0::Int) x = return x
+        opt n x = do
+        wdump FD.Progress $ putErrLn "AE Optimization Pass..."
+        t <- Stats.getTicks stats
+        x <- deadFunctions False stats [funcMain] x
+        x <- Grin.Simplify.simplify stats x
+        typecheckGrin x
+        t' <- Stats.getTicks stats
+        case t == t' of
+            False -> opt (n - 1) x
+            True -> return x
+    x <- opt (-1) x
+    wdump FD.OptimizationStats $ Stats.print "AE Optimization" stats
+
+    x <- return $ normalizeGrin x
+    typecheckGrin x
+    wdump FD.Grin $ printGrin x
+    when (optInterpret options) $ do
+        wdump FD.Progress $ putErrLn "Interpreting..."
+        (v,stats) <- Grin.Interpret.evaluate x
+        CharIO.putStrLn $ render $ Grin.Show.prettyVal v
+        wdump FD.Stats $  Stats.print "Stats" stats
+        return ()
+
+    when (optCompile options) $ do
+        let (cg,rls) = compileGrin x
+        let fn = optOutName options
+        let cf = (fn ++ "_code.c")
+        wdump FD.Progress $ putErrLn ("Writing " ++ show cf)
+        writeFile cf $ cg -- toUTF8  (prettyC z ++ concatMap (\(i,n) -> "//" ++ 'v':show i ++ " -> " ++ n ++ "\n") (snd us))
+        --let comm =  "gcc -std=gnu99 -g -Wall -o '" ++ fn ++ "' '" ++ cf ++ "'"
+        let comm = shellQuote $ [optCC options, "-std=gnu99", "-g", "-Wall", "-o", fn, cf ] ++ rls ++ optCCargs options
+        wdump FD.Progress $ putErrLn ("Running: " ++ comm)
+        r <- System.system comm
+        when (r /= System.ExitSuccess) $ fail "C code did not compile."
+        return ()
+
+
+
+
+mangle = mangle' (Just mempty)
+
+mangle' :: Maybe (Set.Set Int) -- ^ Acceptable free variables
+    -> DataTable
+    -> Bool    -- ^ Whether to dump progress
+    -> String      -- ^ Name of pass
+    -> (E -> IO E) -- ^ Mangling function
+    -> E           -- ^ What to mangle
+    -> IO E        -- ^ Out it comes
+mangle' fv dataTable b  s action e = do
+    when ((b && dump FD.Progress) || dump FD.Pass) $ putErrLn $ "-- " ++ s
+    e' <- action e
+    if not flint then return e' else do
+        let ufreevars e | Just as <- fv = filter ( not . (`Set.member` as) . tvrNum) (freeVars e)
+            ufreevars e = []
+        case inferType dataTable [] e' of
+            Right _ |  xs@(_:_) <- ufreevars e' -> do
+                putErrLn $ "\n>>> internal error: Unaccountable Free Variables\n" ++ render (pprint (xs:: [TVr]))
+                putErrLn $ "\n>>>Before" <+> s
+                printEStats e
+                putDocM CharIO.putErr (ePretty e)
+                putErrLn $ "\n>>>After" <+> s
+                printEStats e'
+                --let (_,e'') = E.Diff.diff e e'
+                let e''' = findOddFreeVars xs e'
+                putDocM CharIO.putErr (ePrettyEx e''')
+                putErrLn $ "\n>>> internal error: Unaccountable Free Variables\n" ++ render (pprint (xs:: [TVr]))
+                case optKeepGoing options of
+                    True -> return e'
+                    False -> putErrDie "Unusual free vars in E"
+            Left ss -> do
+                putErrLn "Type Error..."
+                putErrLn $ "\n>>>Before" <+> s
+                printEStats e
+                putDocM CharIO.putErr (ePretty e)
+                putErrLn $ "\n>>>After" <+> s
+                printEStats e'
+                let (_,e'') = E.Diff.diff e e'
+                putDocM CharIO.putErr (ePretty e'')
+                putErrLn $ "\n>>> internal error:\n" ++ unlines (tail ss)
+                case optKeepGoing options of
+                    True -> return e'
+                    False -> putErrDie "Type Error in E"
+            Right _ -> wdump FD.Stats (printEStats e') >>  return e'
+
+
+typecheck dataTable e = case inferType dataTable [] e of
+    Left ss -> do
+        putErrLn (render $ ePretty e)
+        putErrLn $ "\n>>> internal error:\n" ++ unlines (tail ss)
+        case optKeepGoing options of
+            True -> return Unknown
+            False -> putErrDie "Type Error in E"
+    Right v -> return v
+
+
+
addfile ./Makefile
hunk ./Makefile 1
+
+GHCDEBUGOPTS= -W -fno-warn-unused-matches -fno-warn-unused-binds    # -O2 -ddump-simpl-stats -ddump-rules
+GHCINC=  -iFrontEnd
+PACKAGES= -package mtl  -package unix  #  -prof -auto-all
+GHCOPTS=   -O     -pgmF drift-ghc  -F $(GHCDEBUGOPTS) $(GHCINC) $(PACKAGES) -fwarn-type-defaults   -fallow-undecidable-instances  -fglasgow-exts -fallow-overlapping-instances
+
+HC = ghc
+HC_OPTS = $(GHCOPTS)
+
+DRIFT= ../DrIFT/src/DrIFT
+
+ALLHS:=$(shell find . Grin Boolean Doc C E  FrontEnd DerivingDrift -maxdepth 1 -follow \( -name \*.hs -or -name \*.lhs \) -and \( \! -name Try\*.hs \) | sed -e 's@^\./@@')
+
+OBJS=$(shell ./collect_deps.prl Main.o < depend.make)
+
+
+SUFFIXES= .hs .lhs .o .hi .hsc .c .h .ly .hi-boot .hs-boot .o-boot
+
+all: jhc
+
+MAIN=Main.hs
+
+%.o: %.hs
+	$(HC) -i.  $(HCFLAGS) $(GHCOPTS) -o $@ -c $<
+%.o: %.lhs
+	$(HC) -i.  $(HCFLAGS) $(GHCOPTS) -o $@ -c $<
+
+%.hi: %.o
+	@:
+
+%.hi-boot: %.o-boot
+	@:
+
+%.o-boot: %.hs-boot
+	$(HC) $(HCFLAGS) $(GHCOPTS) -c $<
+
+RawFiles.hs:  data/HsFFI.h data/jhc_rts.c
+	perl ./op_raw.prl $(basename $@)  $^ > $@
+
+FrontEnd/HsParser.hs: FrontEnd/HsParser.ly
+	happy -a -g -c FrontEnd/HsParser.ly
+
+jhc: $(OBJS)
+	$(HC) $(GHCOPTS) $(EXTRAOPTS) $(OBJS) -o $@
+
+tags: $(ALLHS)
+	hasktags $(ALLHS)
+
+regress: jhc Try-Regress.hs
+	time ./regress_test.prl try/Try-Regress.hs
+	time ./regress_test.prl try/Try-Foo.hs
+	time ./regress_test.prl try/Try-Lam.hs
+	time ./regress_test.prl try/Try-Case.hs
+#	$(MAKE) -C regress
+#	(cd regress; ./regress)
+#
+#
+
+hsdocs:
+	haddock -h $(filter-out %/HsParser.hs FrontEnd/Representation.hs C/Gen.hs DData/% E/Subst.hs, $(OBJS:.o=.hs)) -o hsdocs
+
+printos:
+	echo $(ALLHS)
+	echo $(OBJS)
+
+
+depend: $(ALLHS)
+	$(HC) -M -optdep-f -optdepdepend.make $(HC_OPTS) $(ALLHS)
+
+clean:
+	rm -f $(OBJS) jhc *.hs_code.c `find . -name \*.hi -or -name \*.o-boot -or -name \*.hi-boot`
+
+builtfiles: PrimitiveOperators.hs RawFiles.hs FrontEnd/HsParser.hs FlagDump.hs FlagOpts.hs
+
+realclean: clean
+	rm -f PrimitiveOperators.hs RawFiles.hs FrontEnd/HsParser.hs FlagDump.hs FlagOpts.hs
+
+clean-ho:
+	rm -f -- `find -name \*.ho`
+
+%.hs: %.flags  ./opt_sets.prl
+	perl ./opt_sets.prl -n $< $<  > $@
+
+PrimitiveOperators.hs: op_process.prl data/operators.txt data/primitives.txt data/PrimitiveOperators-in.hs
+	perl ./op_process.prl > $@ || rm -f $@
+
+.PHONY: depend clean regress hsdocs
+
+include depend.make
addfile ./MapBinaryInstance.hs
hunk ./MapBinaryInstance.hs 1
+module MapBinaryInstance() where
+
+
+import Binary
+import Data.FiniteMap
+import Data.Map as Map
+import Control.Monad
+
+instance (Ord a,Binary a, Binary b) => Binary (Map a b) where
+    put_ bh x = do
+        put_ bh (Map.size x)
+        mapM_ (put_ bh) (Map.toList x) 
+    get bh = do
+        (sz::Int) <- get bh
+        ls <- replicateM sz (get bh)
+        return (Map.fromList ls)
+        --get bh >>= return . Map.fromList
+
+instance (Ord a,Binary a, Binary b) => Binary (FiniteMap a b) where
+   put_ bh x = put_ bh (fmToList x) 
+   get bh = get bh >>= return . listToFM
addfile ./MonadUtil.hs
hunk ./MonadUtil.hs 1
+module MonadUtil where
+
+import Control.Monad.Error
+import Control.Monad.Identity
+import Control.Monad
+import Data.Monoid
+
+
+class Monad m => ContextMonad c m | m -> c where
+    withContext :: c -> m a -> m a
+
+--class Monad m => UniqueProducerMonad m where
+--    newUniq :: m Int
+
+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
+
+
+
+instance Show a => Show (Identity a) where
+    show x = show $ runIdentity x
+
addfile ./MonoidUtil.hs
hunk ./MonoidUtil.hs 1
+module MonoidUtil where
+
+import Data.Monoid
+import List
+
+infixr 6 <>
+
+empty :: Monoid a => a
+empty = mempty
+(<>) :: Monoid a => a -> a -> a
+(<>) = mappend
+
+
+instance Monoid (IO ()) where
+    mappend a b = a >> b
+    mempty = return ()
+
+--instance (Monoid a, Monoid b) => Monoid (a,b) where
+--    mempty = (mempty,mempty)
+--    mappend (a,b) (c,d) = (mappend a c, mappend b d) 
+--    mconcat xs = case unzip xs of (a,b) -> (mconcat a,mconcat b) 
+--
+--instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+--    mempty = (mempty,mempty,mempty)
+--    mappend (a,b,c) (a',b',c') = (mappend a a', mappend b b', mappend c c') 
+--    mconcat xs = case unzip3 xs of (a,b,c) -> (mconcat a,mconcat b,mconcat c) 
+
+instance Monoid Bool where
+    mempty = False
+    mappend a b = a || b
+    mconcat = or
+
+mconcatMap f xs = mconcat (map f xs)
+mconcatInter x xs = mconcat (intersperse x xs)
+
+
+class  QueryMonoid a where
+    isEmpty :: a -> Bool
+
+
+instance  QueryMonoid (Maybe a) where
+    isEmpty Nothing = True
+    isEmpty _ = False
+
+instance  QueryMonoid [a] where
+    isEmpty = null
+
+instance QueryMonoid Bool where
+    isEmpty = not 
+
+instance QueryMonoid () where
+    isEmpty _ = True
addfile ./Name.hs
hunk ./Name.hs 1
+module Name(
+    NameType(..), 
+    Name, 
+    nameName, 
+    nameType,
+    nameValue,
+    getModule,
+    toUnqualified,
+    qualifyName,
+    toPlainAtom,
+    nameTuple,
+    ToName(..),
+    fromTypishHsName,
+    fromValishHsName,
+    parseName,
+    isConstructorLike,
+    unboxedNameTuple,
+    fromUnboxedNameTuple,
+    setModule
+    ) where
+
+import Data.Generics
+import Atom
+import HsSyn
+import Char
+import VConsts
+import Binary
+import GenUtil
+import Doc.DocLike
+import Doc.PPrint
+
+data NameType = 
+    TypeConstructor 
+    | DataConstructor 
+    | ClassName 
+    | TypeVal 
+    | Val 
+    | SortName  
+    | FieldLabel
+    | RawType 
+    deriving(Ord,Eq,Enum,Read,Show,Typeable,Data)
+
+
+newtype Name = Name Atom 
+    deriving(Ord,Eq,Typeable,Data,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"
+
+instance ValName Name where
+    hsValName (a,b) = toName Val (a,b)
+    hsTypName (a,b) = toName TypeVal (a,b)
+    hsUnqualTypName b = toName TypeVal b
+
+instance ValName HsName where
+    hsValName (a,b) = Qual (Module a) $ HsIdent b
+    hsUnqualValName b = UnQual $ HsIdent b
+
+    
+    
+
+fromTypishHsName, fromValishHsName :: HsName -> Name
+fromTypishHsName name 
+    | isUpper x || x `elem` ":(" = toName TypeConstructor name
+    | otherwise = toName TypeVal name
+    where x = head (hsIdentString . hsNameIdent  $ name) 
+fromValishHsName name 
+    | isUpper x || x `elem` ":(" = toName DataConstructor name
+    | otherwise = toName Val name
+    where x = head (hsIdentString . hsNameIdent  $ name) 
+
+class ToName a where
+    toName :: NameType -> a -> Name 
+    fromName :: Name -> (NameType, a)
+
+instance ToName HsName where
+    toName nt n = Name $ toAtom $ (chr $ fromEnum nt):m ++ "\NUL" ++ i where
+        i = hsIdentString $ hsNameIdent n
+        m | Qual (Module m) _ <- n = m
+          | otherwise = ""
+    fromName n = (nameType n, nameName n) 
+
+instance ToName (String,String) where
+    toName nt (m,i) = Name $ toAtom $ (chr $ fromEnum nt):m ++ "\NUL" ++ i 
+    fromName n = (nameType n, mi ) where
+        nn = nameName n
+        mi  | Qual (Module m) (HsIdent i) <- nn = (m,i) 
+            | UnQual (HsIdent i) <- nn = ("",i)
+
+instance ToName String where
+    toName nt i = Name $ toAtom $ (chr $ fromEnum nt):"\NUL" ++ i 
+    fromName n = (nameType n, m ++ i ) where
+        nn = nameName n
+        (m,i)  | Qual (Module m) (HsIdent i) <- nn = (m ++ ".",i) 
+               | UnQual (HsIdent i) <- nn = ("",i)
+
+
+getModule :: Monad m => Name -> m Module
+getModule n = case nameName n of
+    Qual m _ -> return m
+    UnQual {} -> fail "Name is unqualified."
+
+toUnqualified :: Name -> Name
+toUnqualified n = case fromName n of 
+    (_,UnQual {}) -> n
+    (t,Qual m n) -> toName t (UnQual n)
+
+qualifyName :: Module -> Name -> Name
+qualifyName m n = case fromName n of 
+    (t,UnQual n) -> toName t (Qual m n) 
+    (_,Qual {}) -> n
+
+setModule :: Module -> Name -> Name
+setModule m n = qualifyName m  $ toUnqualified n 
+
+    
+parseName :: NameType -> String -> Name 
+parseName t name = toName t (concatInter "." ms, concatInter "." (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 (ord (head (toString a))) 
+
+nameName :: Name -> HsName
+nameName (Name a) = f $ tail (toString a) where
+    f ('\NUL':xs) = UnQual $ HsIdent xs
+    f xs | (a,_:b) <- span (/= '\NUL') xs  = Qual (Module a) (HsIdent b)
+    f _ = error "invalid Name"
+
+
+instance Show Name where
+    show a = show $ nameName a
+
+toPlainAtom a = toAtom (show a)
+
+hsname m n = (m,n) -- Qual (Module m) $ HsIdent n
+
+
+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 ++ "#)"
+--unboxedNameTuple t n = toName t $ "(#": replicate (n - 1) ',' ++ "#)" 
+
+fromUnboxedNameTuple n = case show n of
+    '(':'#':xs | (ns@(_:_),"#)") <- span isDigit xs -> return (read ns::Int)
+    _ -> fail $ "Not unboxed tuple: " ++ show n 
+
+
+
+instance TypeNames Name where
+    tInt = toName TypeConstructor $ hsname "Prelude" "Int"
+    tBool = toName TypeConstructor $ hsname "Prelude" "Bool"
+    tInteger = toName TypeConstructor $ hsname "Prelude" "Integer"
+    --tRational = toName TypeConstructor $ hsname "Ratio" "Rational"
+    tChar = toName TypeConstructor $ hsname "Prelude" "Char"
+    tStar = toName SortName $ hsname "Prelude" "*"
+    tUnit = toName TypeConstructor $ hsname "Prelude" "()"
+    --tIntzh = toName TypeConstructor $ hsname "Prelude" "Int#"
+    --tCharzh = toName TypeConstructor $ hsname "Prelude" "Char#"
+    tIntzh = toName RawType "int"
+    tCharzh = toName RawType "uint32_t"
+    tIntegerzh = toName RawType "intmax_t"
+    tWorld__ = toName TypeConstructor $ hsname "Jhc.IO" "World__"
+
+instance ConNames Name where
+    vTrue = toName DataConstructor $ hsname "Prelude" "True"
+    vFalse = toName DataConstructor $ hsname "Prelude" "False"
+    vEmptyList = toName DataConstructor $ hsname "Prelude" "[]"
+    vUnit = toName DataConstructor $ hsname "Prelude" "()"
+    vCons = toName DataConstructor $ hsname "Prelude" ":"
+
+instance ToTuple Name where
+    toTuple n = toName DataConstructor (toTuple n :: (String,String))
+
+
+instance DocLike d => PPrint d Name  where
+    pprint n = text (show n)
+
+{-
+instance ClassNames Name where 
+    classEq :: a
+    classOrd :: a
+    classEnum :: a
+    classBounded :: a
+    classShow :: a
+    classRead :: a
+    classIx :: a
+    classFunctor :: a
+    classMonad :: a
+    classNum  :: a
+    classReal :: a
+    classIntegral :: a
+    classFractional :: a
+    classFloating :: a
+    classRealFrac :: a
+    classRealFloat :: a
+
+-}
+
+nameValue m n = atomIndex $ toAtom (toName Val (m,n)) 
addfile ./NameMonad.hs
hunk ./NameMonad.hs 1
+module NameMonad(NameMonad(..), GenName(..), NameMT, 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 Atom
+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 ()
+    -- | 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 
+
+
+    --  | get bound names
+    -- getNames :: m [n]
+
+class GenName n where
+    -- | Generate a list of canidate names given a seed
+    genNames :: Int -> [n]
+
+instance GenName Int where
+    genNames i = [st, st + 2 ..]  where
+        st = abs i + 2 + abs i `mod` 2
+
+instance GenName Atom where
+    genNames i = map (toAtom . show) [abs i..]
+    
+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 
+    newName = lift  newName 
+    newNameFrom y = lift $ newNameFrom y
+    uniqueName y = lift $ uniqueName y
+
+    --getNames = lift getNames
+
+newtype NameMT n m a = NameMT (StateT (Set.Set n, Set.Set n) m a)
+    deriving(Monad, MonadTrans, Functor, MonadFix, MonadPlus, MonadIO)
+
+runNameMT (NameMT x) = liftM fst $ runStateT x (Set.empty,Set.empty)
+
+
+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) )
+    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 (v:vs) 
+                | v `Set.member` used = f vs
+                | otherwise = v
+            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))
+        
+    --getNames  = NameMT $ do
+    --    fmap Set.toList get 
+        
+    
addfile ./Number.hs
hunk ./Number.hs 1
+module Number(Number(..),TypeInfo,toIntegral) where
+
+import Ratio
+import Name 
+import Binary
+import Data.Generics
+
+data NumType = Signed | Unsigned | Floating | Pointer
+data Value a = Known a | Unknown | AtLeast a | GreatestOfAll
+
+data TypeInfo = TypeInfo {
+    typeType :: NumType, 
+    typeBytes :: Value Int
+    }
+
+{-
+signed v n = (toName RawType v,TypeInfo Signed (Known n)) 
+unsigned v n = (toName RawType v,TypeInfo Unsigned (Known n)) 
+typeTable = [
+    signed "int" 0 { typeBytes = AtLeast 4 },
+    unsigned "unsigned int" 0 { typeBytes = AtLeast 4 },
+    signed "int8_t" 1, 
+    signed "int16_t" 2, 
+    signed "int32_t" 4, 
+    signed "int64_t" 8, 
+    signed "intmax_t" 0 { typeBytes = GreatestOfAll },
+    signed "intptr_t" 0 { typeBytes = AtLeast 4 },
+    unsigned "uint8_t" 1, 
+    unsigned "uint16_t" 2, 
+    unsigned "uint32_t" 4, 
+    unsigned "uint64_t" 8, 
+    unsigned "uintmax_t" 0 { typeBytes = GreatestOfAll },
+    unsigned "uintptr_t" 0 { typeBytes = AtLeast 4 },
+    unsigned "wchar_t" 0   { typeBytes = AtLeast 4 },
+    signed "wint_t" 0   { typeBytes = AtLeast 4 },
+    unsigned "size_t" 0   { typeBytes = AtLeast 4 },
+    signed "ssize_t" 0   { typeBytes = AtLeast 4 },
+    (toName RawType "HsPtr", TypeInfo Pointer (AtLeast 4)),
+    (toName RawType "HsFunPtr", TypeInfo Pointer (AtLeast 4)),
+    unsigned "char" 1,
+    unsigned "short" 2 { typeBytes = AtLeast 2 }
+    ]
+
+ -}   
+    
+newtype Number = Number Rational 
+    deriving(Num,Eq,Ord,Binary,Real,Fractional,RealFrac,Enum,Typeable,Data)
+
+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
+
+--instance Show Number where 
+
+--data Number = Number {
+--    numberValue :: Ratio, 
+--    numberType :: Atom 
+--    }
+
+
addfile ./Options.hs
hunk ./Options.hs 1
+{-# OPTIONS -w -funbox-strict-fields #-}
+module Options(processOptions, Opt(..), options, putVerbose, putVerboseLn, verbose, verbose2, dump, wdump, fopts, flint, fileOptions) where
+
+import GenUtil
+import System
+import System.Console.GetOpt
+import System.IO.Unsafe
+import Monad
+import Control.Monad.Error
+import qualified Data.Set as S
+import qualified FlagDump
+import qualified FlagOpts
+
+data Opt = Opt {
+    optColumns     :: !Int,
+    optCompile     :: !Bool,
+    optDebug       :: !Bool,
+    optDump        ::  [String],
+    optFOpts       ::  [String],
+    optIncdirs     ::  [String],
+    optProgArgs    ::  [String],
+    optShowHo      ::  [String],
+    optCCargs      ::  [String],
+    optCC          ::  String,
+    optArgs        ::  [String],
+    optInteractive :: !Bool,
+    optInterpret   :: !Bool,
+    optKeepGoing   :: !Bool,
+    optMainFunc    ::  Maybe (Bool,String),
+    optOutName     ::  String,
+    optPrelude     :: !Bool,
+    optIgnoreHo    :: !Bool,
+    optNoWriteHo   :: !Bool,
+    optVerbose     :: !Int,
+    optDumpSet     ::  S.Set FlagDump.Flag,
+    optFOptsSet    ::  S.Set FlagOpts.Flag
+  } deriving(Show) {-!derive: update !-}
+
+
+opt = Opt {
+    optColumns     = getColumns,
+    optCompile     = True,
+    optDebug       = False,
+    optIncdirs     = initialIncludes,
+    optProgArgs    = [],
+    optDump        = [],
+    optFOpts       = ["default"],
+    optShowHo      = [],
+    optCCargs      = [],
+    optCC          = "gcc",
+    optArgs        = [],
+    optInteractive = False,
+    optIgnoreHo    = False,
+    optNoWriteHo   = False,
+    optInterpret   = False,
+    optKeepGoing   = False,
+    optMainFunc    = Nothing,
+    optOutName     = "hs.out",
+    optPrelude     = True,
+    optVerbose     = 0,
+    optDumpSet     = S.empty,
+    optFOptsSet    = S.empty
+}
+
+idu "-" _ = []
+idu d ds = ds ++ [d]
+
+theoptions :: [OptDescr (Opt -> Opt)] 
+theoptions =
+    [ Option ['v'] ["verbose"]   (NoArg  (optVerbose_u (+1)))    "chatty output on stderr"
+    , Option ['d'] []            (ReqArg (\d -> optDump_u (d:)) "dump-flag")  "dump specified data to stdout"
+    , Option ['f'] []            (ReqArg (\d -> optFOpts_u (d:)) "flag")  "set compilation options"
+    , Option ['o'] ["output"]    (ReqArg (optOutName_s) "FILE")  "output to FILE"
+    , Option ['i'] ["include"]   (ReqArg (\d -> optIncdirs_u (idu d)) "DIR") "library directory"
+    , Option []    ["optc"]      (ReqArg (\d -> optCCargs_u (idu d)) "option") "extra options to pass to c compiler"
+    , Option []    ["progc"]     (ReqArg (\d -> optCC_s d) "CC") "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'] ["justcheck"] (NoArg  (optCompile_s False))   "don't compile. just typecheck."
+    , Option ['I'] ["interpret"] (NoArg  (optInterpret_s True . optCompile_s False)) "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 ['m'] ["main"]      (ReqArg (optMainFunc_s . Just . (,) False) "Main.main")  "main entry point."
+    , Option ['e'] []            (ReqArg (optMainFunc_s . Just . (,) True)  "<expr>")  "main entry point, showable expression."
+    , Option []    ["debug"]     (NoArg  (optDebug_s True)) "debugging"
+    , Option []    ["show-ho"]   (ReqArg  (\d -> optShowHo_u (++ [d])) "file.ho") "Show ho file"
+    , Option []    ["interactive"] (NoArg  (optInteractive_s True)) "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"
+    ]  
+
+getColumns :: Int
+getColumns = read $ unsafePerformIO (getEnv "COLUMNS" `mplus` return "80")
+    
+
+postProcess o = case FlagDump.process (optDumpSet o) (optDump o ++ vv) of
+        (s,errs) -> (o { optDumpSet = s }, f errs) where
+                f [] = ""
+                f xs = "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 = []
+
+postProcess' o = case FlagOpts.process (optFOptsSet o) (optFOpts o) of
+        (s,errs) -> (o { optFOptsSet = s }, f errs) where
+                f [] = ""
+                f xs = "Unrecognized flag passed to '-f': " ++ unwords xs ++ "\nValid flags:\n\n" ++ FlagOpts.helpMsg
+    
+
+{-# NOINLINE processOptions #-}
+processOptions = do
+    argv <- System.getArgs
+    let header = "Usage: jhc [OPTION...] Main.hs"
+    case (getOpt Permute theoptions argv) of
+	  (o,ns,[]) -> case postProcess (foldl (flip ($)) opt o) of 
+                (o,"") -> case postProcess' o of 
+                    (o,"") -> return (o { optArgs = ns })
+                    (_,err) -> putErrDie err
+                (_,err) -> putErrDie err
+	  --(_,_,[]) -> putErrDie (usageInfo header options)
+	  (_,_,errs) -> putErrDie (concat errs ++ usageInfo header theoptions)
+
+{-# NOINLINE fileOptions #-}
+fileOptions :: Monad m => [String] -> m Opt
+fileOptions xs = case getOpt Permute theoptions xs of
+    (os,[],[]) -> case postProcess (foldl (flip ($)) options os) of
+            (o,"") -> return o
+            (_,err) -> fail err
+    (_,_,errs) -> fail (concat errs)
+
+{-# NOINLINE options #-}
+options :: Opt
+options = unsafePerformIO processOptions
+
+putVerbose s = when (optVerbose options > 0) $ putErr s
+putVerboseLn s = putVerbose (s ++ "\n") 
+
+verbose = optVerbose options > 0
+verbose2 = optVerbose options > 1
+
+--dump s = s `S.member` S.fromList (optDump options)
+
+dump s = s `S.member` optDumpSet options
+fopts s = s `S.member` optFOptsSet options
+wdump f = when (dump f) 
+
+flint = FlagOpts.Lint `S.member` optFOptsSet options 
+
+initialIncludes = unsafePerformIO $ do
+    p <- lookupEnv "JHCPATH"
+    Just x <- return $  p `mplus` Just ""
+    return (".":(tokens (== ':') x))
+    
addfile ./PackedString.hs
hunk ./PackedString.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- 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
+        -- 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
+
+{-
+	headPS,      -- :: PackedString -> Char
+	tailPS,      -- :: PackedString -> PackedString
+	lengthPS,    -- :: PackedString -> Int
+	indexPS,     -- :: PackedString -> Int -> Char
+	mapPS,       -- :: (Char -> Char) -> PackedString -> PackedString
+	filterPS,    -- :: (Char -> Bool) -> PackedString -> PackedString
+	reversePS,   -- :: PackedString -> PackedString
+	elemPS,      -- :: Char -> PackedString -> Bool
+	substrPS,    -- :: PackedString -> Int -> Int -> PackedString
+	takePS,      -- :: Int -> PackedString -> PackedString
+	dropPS,      -- :: Int -> PackedString -> PackedString
+	splitAtPS,   -- :: Int -> PackedString -> (PackedString, PackedString)
+
+	foldlPS,     -- :: (a -> Char -> a) -> a -> PackedString -> a
+	foldrPS,     -- :: (Char -> a -> a) -> a -> PackedString -> a
+	takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+	dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
+	spanPS,      -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+	breakPS,     -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+	linesPS,     -- :: PackedString -> [PackedString]
+	unlinesPS,   -- :: [PackedString] -> PackedString
+	wordsPS,     -- :: PackedString -> [PackedString]
+	unwordsPS,   -- :: [PackedString] -> PackedString
+	splitPS,     -- :: Char -> PackedString -> [PackedString]
+	splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
+
+	-- * I\/O with @PackedString@s	
+	hPutPS,      -- :: Handle -> PackedString -> IO ()
+	hGetPS,      -- :: Handle -> Int -> IO PackedString
+    -}
+
+
+    ) where
+
+import Prelude
+
+
+import Data.Array.Unboxed
+import Data.Array.IO
+import Data.Typeable
+import Data.Char
+
+import Int
+import Bits
+import GHC.Exts
+import Data.Array.Base
+import Word
+import Data.Monoid
+import Data.Generics
+import Data.Generics.Basics
+
+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 (UArray Int Word8)
+    deriving(Typeable)
+
+instance Data PackedString where
+    toConstr _   = error "toConstr"
+    --fromConstr _   = error "fromConstr"
+    --gfoldl f g x  = g x
+    --dataTypeOf _ = mkDataType []
+
+
+instance Eq PackedString where
+   (PS x) == (PS y)  =  x == y
+
+instance Ord PackedString where
+    compare (PS x) (PS y) = compare x y
+
+
+instance Show PackedString where
+    showsPrec p ps r = showsPrec p (unpackPS ps) r
+--instance Read PackedString: ToDo
+
+
+-- -----------------------------------------------------------------------------
+-- Constructor functions
+
+-- | The 'nilPS' value is the empty string.
+nilPS :: PackedString
+nilPS = PS (array (0,-1) [])
+
+-- | 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 $ listArray (0, I# (utfCount str -# 1#)) (toUTF str)
+
+
+-- -----------------------------------------------------------------------------
+-- Destructor functions (taking PackedStrings apart)
+
+
+unpackPS :: PackedString -> String
+unpackPS (PS (UArray _ (I# e) ba)) = unpackFoldrUtf8# (ba) (e +# 1#) f [] where
+    f ch r = C# ch : r
+
+
+toUTF8 :: PackedString -> [Word8]
+toUTF8 (PS ba) = elems 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) = rangeSize (bounds ps) == 0
+
+-- | The 'appendPS' function appends the second string onto the first.
+appendPS :: PackedString -> PackedString -> PackedString
+appendPS xs ys
+  | nullPS xs = ys
+  | nullPS ys = xs
+  | otherwise  = concatPS [xs,ys]
+
+-- | The 'mapPS' function applies a function to each character in the string.
+--mapPS :: (Char -> Char) -> PackedString -> PackedString
+--mapPS f (PS ps) = PS (amap f ps)
+
+-- | 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 (elems 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"
+
+
+-- | Convert Unicode characters to UTF-8.
+toUTF :: String -> [Word8]
+toUTF [] = []
+toUTF (x:xs) | ord x<=0x007F = (fromIntegral $ ord x):toUTF xs
+	     | ord x<=0x07FF = fromIntegral (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):
+			       fromIntegral (0x80 .|. (ord x .&. 0x3F)):
+			       toUTF xs
+	     | otherwise     = fromIntegral (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):
+			       fromIntegral (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):
+			       fromIntegral (0x80 .|. (ord x .&. 0x3F)):
+			       toUTF xs
+
+
+
+
+
+
+{-# 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"
+
+-}
addfile ./Relation.hs
hunk ./Relation.hs 1
+module Relation(module Relation, module Set) where
+
+import Data.Set as Set hiding(map)
+
+type Rel a b = Set (a,b)
+
+
+--domain :: Rel a b -> Set a
+--range :: Rel a b -> Set b
+
+domain r = fromAscList (map fst (toAscList r)) 
+range r = fromList [ y | (_,y) <- toList r ]
+
+
+restrictDomain f r = Set.filter (f . fst) r 
+restrictRange f r = Set.filter (f . snd) r 
+
+
+mapDomain f r = fromList [ (f x,y)| (x,y) <- toList r ]
+mapRange f r = fromList [ (x,f y)| (x,y) <- toList 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 = 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)] 
addfile ./SameShape.hs
hunk ./SameShape.hs 1
+module 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
+
+
addfile ./Seq.hs
hunk ./Seq.hs 1
+--------------------------------------------------------------------------------
+{-| 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 Seq( -- * Type
+            Seq
+            -- * Operators
+          , (<>)
+
+            -- * Construction
+          , empty
+          , single
+          , singleton
+          , cons
+          , append
+
+            -- * Conversion
+          , toList
+          , fromList
+          ) where
+
+import Data.Monoid
+import Monad
+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])
+    deriving(Monoid)
+
+{--------------------------------------------------------------------
+  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 (Seq.singleton x)
+tells xs = W.tell (Seq.fromList xs)
+
+--instance Monoid (Seq.Seq a) where
+--    mempty = Seq.empty
+--    mappend = (Seq.<>)
+
+concat :: Seq (Seq a) -> Seq a 
+concat (Seq f) = (foldr Seq.append Seq.empty (f [])) 
+
+instance Functor 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 Seq.Seq where
+    --a >>= b  = mconcat ( fmap b (Seq.toList a))
+    a >>= b  = Seq.concat (fmap b a)
+    return x = Seq.single x
+    fail _ = Seq.empty
+
+instance MonadPlus Seq.Seq where
+    mplus = mappend
+    mzero = Seq.empty
+
+
+
+
addfile ./Stats.hs
hunk ./Stats.hs 1
+module Stats(Stats,new,tick,ticks,getTicks,Stats.print,clear,MonadStats(..),combine, printStat, Stat, mtick, mticks, runStatT, runStatIO, tickStat, StatT, theStats ) where
+
+
+import qualified Data.HashTable as H
+import Atom
+import GenUtil
+import List(sort,groupBy)
+import CharIO
+import Data.Tree
+import qualified Doc.Chars as C
+import Char
+import Data.IORef
+import Control.Exception
+import Control.Monad.Trans
+import Control.Monad.Writer
+import Control.Monad.Reader
+import Control.Monad.Identity
+import Control.Monad.Fix
+import System.IO.Unsafe
+import qualified Data.Map as Map
+
+
+data Stats = Stats !(IORef Int) !(H.HashTable Atom Int)
+
+    
+                    
+{-# NOINLINE theStats #-}
+theStats :: Stats
+theStats = unsafePerformIO new
+
+
+
+combine :: Stats -> Stats -> IO ()
+combine stats (Stats _ h2) = do
+    --c <- readIORef c2
+    --modifyIORef c1 (+ c)
+    ls <- H.toList h2
+    let f (a,i) = ticks stats i a
+    mapM_ f ls 
+    
+
+new = do
+    h <- H.new (==) (fromIntegral . atomIndex) 
+    r <- newIORef 0
+    return $ Stats r h
+
+clear (Stats r h) = do
+    writeIORef r 0
+    xs <- H.toList h 
+    mapM_ (H.delete h) (fsts xs)
+
+toList (Stats _ h) = H.toList h
+
+getTicks (Stats r _)  = readIORef r 
+
+tick stats k = ticks stats 1 k
+
+
+ticks _ 0 _ = return ()
+ticks (Stats r h) c k' = do
+    let k = toAtom k'
+    liftIO $ modifyIORef r (+ c)
+    liftIO $ readIORef r >>= evaluate
+    v <- liftIO $ H.lookup h k
+    case v of
+        Just n -> liftIO $ H.delete h k >> (H.insert h k $! (n + c))
+        Nothing -> liftIO $ H.insert h k c
+
+splitUp str = filter (not . null) (f str)  where
+    f str = case span (`notElem` ".{") str  of
+     (x,"") -> [x]
+     (x,('.':rs)) -> x:f rs
+     (x,('{':rs)) -> case span (/= '}') rs of
+            (a,'}':b) -> x:a:f b
+            (a,"") -> [x,a]
+
+
+print greets stats = do
+    l <- toList stats
+    --let fs = createForest 0 $ sort [(split (== '.') $ fromAtom x,y) | (x,y) <- l]
+    let fs = createForest 0 $ sort [(splitUp $ fromAtom x,y) | (x,y) <- l]
+    --CharIO.putErrLn greets
+    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
+    --[Node (concat $ intersperse "." (xs),y) [] | (xs,y) <- xs] 
+    f [(xs,ys)] =  Node (concatInter "." 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
+--createForest  xs = Node ("","") [ createTree [(xs,y)] | (xs,y) <- xs]
+
+draw :: Tree String -> [String]
+draw (Node x ts0) = x : drawSubTrees ts0
+  where drawSubTrees [] = []
+        drawSubTrees [t] =
+                {-[vLine] :-} shift [chr 0x2570, chr 0x2574] "  " (draw t)
+        drawSubTrees (t:ts) =
+                {-[vLine] :-} shift (C.lTee ++ [chr 0x2574]) (C.vLine  ++ " ") (draw t) ++ drawSubTrees ts
+
+        shift first other = zipWith (++) (first : repeat other)
+        --vLine = chr 0x254F
+        
+tickStat ::  Stats -> Stat -> IO ()
+tickStat stats (Stat stat) = sequence_  [ ticks stats n a | (a,n) <- Map.toList stat]
+
+runStatIO :: MonadIO m =>  Stats -> StatT m a -> m a 
+runStatIO stats action = do
+    (a,s) <- runStatT action
+    liftIO $ tickStat stats s
+    return a
+
+instance MonadStats IO where 
+    mticks' n a = ticks theStats n a
+
+-- Pure varients
+        
+newtype Stat = Stat (Map.Map Atom Int)
+    
+printStat greets (Stat s) = do
+    let fs = createForest 0 $ sort [(splitUp $ fromAtom x,y) | (x,y) <- Map.toList s]
+    mapM_ CharIO.putErrLn $ ( draw . fmap p ) (Node (greets,0) fs)  where
+        p (x,0) = x
+        p (x,n) = x ++ ": " ++ show n
+
+{-
+instance DocLike d => PPrint d Stat where 
+    pprint (Stat s) =  ( draw . fmap p ) (Node (greets,0) fs)  where
+        fs = createForest 0 $ sort [(splitUp $ fromAtom x,y) | (x,y) <- Map.toList s]
+        p (x,0) = x
+        p (x,n) = x ++ ": " ++ show n
+-}
+
+instance Monoid Stat where
+    mempty = Stat Map.empty
+    mappend (Stat a) (Stat b) = Stat $ Map.unionWith (+) a b
+    --mconcat xs = Stat $ Map.unionsWith (+) [ x | Stat x <- xs]
+    
+    
+newtype StatT m a = StatT (WriterT Stat m a)
+    deriving(MonadIO, Functor, MonadFix, MonadTrans, Monad)
+    
+runStatT (StatT m) =  runWriterT m 
+
+class Monad m => MonadStats m where
+    mticks' ::  Int -> Atom -> m ()
+
+-- These are inlined so the 'toAtom' can become a caf and be shared 
+{-# INLINE mtick  #-}
+{-# INLINE mticks #-}
+mtick k = mticks' 1 (toAtom k)
+mticks n k = n `seq` mticks' n (toAtom k)
+
+--instance (Monad m, Monad (t m), MonadTrans t, MonadReader r m) => MonadReader r (t m) where
+--    ask = lift $ ask 
+  --  (r -> r) ->  m a -> t m a
+  --  (r -> r) -> m a -> m a
+  --  local l m = local l m
+  --  mticks' n k = lift $ mticks' n k
+
+instance MonadStats Identity where
+    mticks' _ _ = 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
+    
+instance Monad m => MonadStats (StatT m) where
+    mticks' n k = StatT $ tell (Stat $ Map.singleton k n)
+
+
addfile ./UTF8.hs
hunk ./UTF8.hs 1
+--  $Id: UTF8.hs,v 1.4 2004/02/28 04:20:46 john Exp $
+-- arch-tag: 596040c5-d420-4cc6-add6-c4612cfe2d27
+
+module UTF8(toUTF, fromUTF) where
+
+import Bits
+import Char
+import Word(Word8)
+
+
+
+-- | Convert Unicode characters to UTF-8.
+toUTF :: String -> [Word8]
+toUTF [] = []
+toUTF (x:xs) | ord x<=0x007F = (fromIntegral $ ord x):toUTF xs
+	     | ord x<=0x07FF = fromIntegral (0xC0 .|. ((ord x `shift` (-6)) .&. 0x1F)):
+			       fromIntegral (0x80 .|. (ord x .&. 0x3F)):
+			       toUTF xs
+	     | otherwise     = fromIntegral (0xE0 .|. ((ord x `shift` (-12)) .&. 0x0F)):
+			       fromIntegral (0x80 .|. ((ord x `shift` (-6)) .&. 0x3F)):
+			       fromIntegral (0x80 .|. (ord x .&. 0x3F)):
+			       toUTF xs
+
+-- | 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"
addfile ./UniqueMonad.hs
hunk ./UniqueMonad.hs 1
+module 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
+
+runUniqT :: Monad m =>  UniqT m a -> Int -> m (a,Int)
+runUniqT (UniqT sm) s  = runStateT sm s
+
+runUniq :: Int -> Uniq a -> (a,Int)
+runUniq x y = runIdentity $ runUniqT y x
+
+execUniq1 x = fst $ runUniq 1 x  
+execUniq st x = fst $ runUniq st x  
+
+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
+
+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
+    
+type Uniq a = UniqT Identity a
+--newtype Uniq a = Uniq (UniqT Identity)
+--    deriving(Monad,UniqueProducer)
addfile ./Unparse.hs
hunk ./Unparse.hs 1
+module Unparse(Unparse, Unparsable(..), unparse, Side(..), Fix(..), atom, bop, pop) where
+
+type Unparse a = (a, Fix)
+
+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 _ _ = ()
+
+unparse :: Unparsable a => Unparse a -> a
+unparse = fst
+
+data Side = R | L | N
+    deriving(Eq)
+
+data Fix = Atom | Pre | Fix !Side !Int
+
+
+lts _ _ Atom = True
+lts _ _ Pre = True
+lts _ (_,n') (Fix  _ n ) | n' /= n = n' < n
+lts R (R,_) (Fix  R _ ) = True
+lts L (L,_) (Fix  L _ ) = True
+lts _ _ _ = False
+--lts _ (N,_) (Fix (N,_)) = False
+
+atom :: a -> Unparse a
+atom s = (s, Atom)
+
+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)
+
+
+
+{-
+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 ]
+-}
addfile ./VConsts.hs
hunk ./VConsts.hs 1
+module VConsts where
+
+import Data.FunctorM
+
+-- This is much more verbose/complicated than it needs be.
+
+class TypeNames a where
+    tInt :: a 
+    tRational :: a 
+    tChar :: a
+    tIntzh :: a
+    tIntegerzh :: a
+    tCharzh :: a
+    tStar :: a
+    tBool :: a
+    tUnit :: a
+    tString :: a
+    tInteger :: a
+    tWorld__ :: a 
+
+    tInt = error "tInt"
+    tRational = error "tRational"
+    tChar = error "tChar"
+    tIntzh = error "tIntzh"
+    tIntegerzh = error "tIntegerzh"
+    tCharzh = error "tCharzh"
+    tStar = error "VConsts: tStar"
+    tBool = error "tBool"
+    tUnit = error "tUnit"
+    tString = error "tString"
+    tInteger = error "tInteger"
+    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 ("Prelude",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 = ("Prelude",toTuple n)
+
+
+--class Tupleable a where
+--    toTuple :: [a] -> a
+
+
+-- This is stupid
+class ClassNames a where
+    classEq :: a
+    classOrd :: a
+    classEnum :: a
+    classBounded :: a
+    classShow :: a
+    classRead :: a
+    classIx :: a
+    classFunctor :: a
+    classMonad :: a
+    classNum  :: a
+    classReal :: a
+    classIntegral :: a
+    classFractional :: a
+    classFloating :: a
+    classRealFrac :: a
+    classRealFloat :: a
+
+class ValName a where
+    hsValName :: (String,String) -> a
+    hsUnqualValName :: String -> a
+    hsTypName ::  (String,String) -> a
+    hsUnqualTypName :: String -> a
+
+    hsUnqualValName s = hsValName ("",s)
+    hsTypName = hsValName
+    hsUnqualTypName = hsUnqualValName
+
+
+-- | various functions needed for desugaring.
+data FuncNames a = FuncNames {
+    func_bind :: a,
+    func_bind_ :: a,
+    func_negate :: a,
+    func_runMain :: a,
+    func_runExpr :: a,
+    func_fromInt :: a,
+    func_fromInteger :: a,
+    func_fromRational :: a,
+    func_equals :: a,
+    func_concatMap :: a
+    } 
+    {-! derive: FunctorM !-}
+
+sFuncNames = FuncNames {
+    func_bind = ("Prelude",">>="),
+    func_bind_ = ("Prelude",">>"),
+    func_negate = ("Prelude","negate"),
+    func_runMain = ("Prelude.IO","runMain"),
+    func_fromInt = ("Prelude","fromInt"),
+    func_fromInteger = ("Prelude","fromInteger"),
+    func_fromRational = ("Prelude","fromRational"),
+    func_runExpr = ("Prelude.IO","runExpr"),
+    func_equals = ("Prelude","=="),
+    func_concatMap = ("Prelude","concatMap")
+    }
+
+
+instance ClassNames (String,String) where
+    classEq = ("Prelude","Eq")
+    classOrd = ("Prelude","Ord")
+    classEnum = ("Prelude","Enum")
+    classBounded = ("Prelude","Bounded")
+    classShow = ("Prelude.Text","Show")
+    classRead = ("Prelude.Text","Read")
+    classIx = ("Ix","Ix")
+    classFunctor = ("Prelude","Functor")
+    classMonad = ("Prelude","Monad")
+    classNum = ("Prelude","Num")
+    classReal = ("Prelude","Real")
+    classIntegral = ("Prelude","Integral")
+    classFractional = ("Prelude","Fractional")
+    classFloating = ("Prelude","Floating")
+    classRealFrac = ("Prelude","RealFrac")
+    classRealFloat = ("Prelude","RealFloat")
+
+derivableClasses,numClasses,stdClasses :: ClassNames a => [a]
+
+stdClasses = [
+    classEq,
+    classOrd,
+    classEnum,
+    classBounded,
+    classShow,
+    classRead,
+    classIx,
+    classFunctor,
+    classMonad,
+    classNum ,
+    classReal,
+    classIntegral,
+    classFractional,
+    classFloating,
+    classRealFrac,
+    classRealFloat
+    ]
+
+numClasses = [
+    classNum ,
+    classReal,
+    classIntegral,
+    classFractional,
+    classFloating,
+    classRealFrac,
+    classRealFloat
+    ]
+
+
+derivableClasses = [
+    classEq,
+    classOrd,
+    classEnum,
+    classBounded,
+    classShow,
+    classRead
+    ]
addfile ./collect_deps.prl
hunk ./collect_deps.prl 1
+#!/usr/bin/perl
+
+use strict;
+use Data::Dumper;
+
+my %deps;
+
+while(<STDIN>) {
+    next if /^\s*$/;
+    next if /^\s*#/;
+    next unless /^\s*(\S*)\s*\:\s*(\S*)\s*$/;
+    my ($a,$b) = ($1,$2);
+    $b =~ s/^(\.\/)?(.*)\.[a-z-]+$/$2.o/;
+    push @{$deps{$a}}, $b;
+}
+
+my @todo = @ARGV;
+my %done;
+
+while(my $do = pop @todo) {
+    foreach (@{$deps{$do}}) {
+        push @todo, $_, unless $done{$_};
+    }
+    $done{$do} = 1;
+}
+
+print (join(" ", keys %done), "\n");
+
+#print Dumper(\%deps);
addfile ./data/HsFFI.h
hunk ./data/HsFFI.h 1
+/* HsFFI.h for jhc */
+
+#include <inttypes.h>
+
+typedef int HsInt;
+typedef uint32_t HsChar;
+typedef int8_t HsInt8;
+typedef int16_t HsInt16;
+typedef int32_t HsInt32;
+typedef int64_t HsInt64;
+typedef uint8_t HsWord8;
+typedef uint16_t HsWord16;
+typedef uint32_t HsWord32;
+typedef uint64_t HsWord64;
+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);
+
+
addfile ./data/PrimitiveOperators-in.hs
hunk ./data/PrimitiveOperators-in.hs 1
+
+{- This file is generated -}
+module PrimitiveOperators(primitiveInsts,constantMethods,theMethods,allCTypes) where
+
+import Representation
+import E.E
+import E.Values
+import C.Prims
+import VConsts
+import Name
+import Data.Monoid
+
+toHsName x = nameName $ parseName TypeConstructor x
+
+toInstName x = toName Val ("Instance@",'i':x)
+
+unbox' e cn tvr wtd = ECase e (tVr 0 te) [Alt (LitCons cn [tvr] te) wtd] Nothing where
+    te = typ e
+
+oper_aa op ct e = EPrim (APrim (Operator op [ct] ct) mempty) [e] (rawType ct)
+oper_aaI op ct a b = EPrim (APrim (Operator op [ct,ct] "int") mempty) [a,b] intt
+oper_aaa op ct a b = EPrim (APrim (Operator op [ct,ct] ct) mempty) [a,b] (rawType ct)
+oper_aIa op ct a b = EPrim (APrim (Operator op [ct,"int"] ct) mempty) [a,b] (rawType ct)
+
+intt = rawType "int"
+zeroI =  LitInt 0 intt
+
+op_aIa 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 tInt
+    tvra = tVr 6 st 
+    tvrb = tVr 8 intt
+    tvrc = tVr 10 st 
+    st = rawType ct
+    wtd = eStrictLet tvrc (oper_aIa op ct (EVar tvra) (EVar tvrb)) (rebox (EVar tvrc))
+    rebox x = ELit (LitCons cn [x] 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 cn [x] 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 cn [x] 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 d_Prelude_Int [x] 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 intt
+    st = rawType ct
+    wtd = eStrictLet tvrc (oper_aaI op ct (EVar tvra) (EVar tvrb)) (caseof (EVar tvrc))
+    caseof x = eCase x [Alt zeroI vFalse]  vTrue
+
+--buildAbs v t = eIf (EPrim (primPrim "prim_op_aaB.<") [EVar v,(ELit (LitInt 0 t))] tBool) (EPrim (primPrim "prim_op_aa.-") [EVar v] t) (EVar v)
+--build_abs ct cn v = unbox' v cn tvra (eCase (EPrim (APrim (Operator "<" [ct,ct] "int") mempty) [EVar tvra, zero] intt) [Alt zeroI (rebox $ EVar tvra)] (fs)) where
+build_abs ct cn v = unbox' v cn tvra (eCase (oper_aaI "<" ct (EVar tvra) zero)  [Alt zeroI (rebox $ EVar tvra)] (fs)) where
+    te = typ v
+    tvra = tVr 2 st  
+    tvrb = tVr 4 st  
+    zero = ELit $ LitInt 0 st
+    st = rawType ct
+    intt =  rawType "int"
+    fs = eStrictLet tvrb (oper_aa "-" ct (EVar tvra)) (rebox (EVar tvrb))
+    rebox x = ELit (LitCons cn [x] te) 
+
+buildSignum v t = eCase (EVar v) [Alt (LitInt 0 t) (ELit (LitInt 0 t))] (eIf (EPrim (primPrim "prim_op_aaB.<") [EVar v,(ELit (LitInt 0 t))] tBool) (ELit (LitInt (-1) t)) (ELit (LitInt 1  t)))
+build_signum ct cn v = unbox' v cn tvra (eCase (EVar tvra) [Alt zero (rebox (ELit zero))] (eCase (oper_aaI "<" ct (EVar tvra) (ELit zero)) [Alt zeroI (rebox one)] (rebox negativeOne))) where
+    tvra = tVr 2 st 
+    te = typ 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 cn [x] 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 "HsPtr")
+    tvrWorld2 = tVr 258 tWorld__
+    tvrWorld = tVr 256 tWorld__
+    rtVar = tVr 260 (rawType p)
+    rtVar' = tVr 262 t
+    rest = eCaseTup' (EPrim (APrim (Peek p) mempty) [EVar tvrWorld, EVar tvr'] (ltTuple' [tWorld__,rawType p])) [tvrWorld2,rtVar] (eLet rtVar' (ELit $ LitCons cn [EVar rtVar] 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 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 "HsPtr"))
+    v_tvr' = tVr 8 (rawType p)
+
+toIO :: E -> E -> E
+toIO t x = x
+
+{-
+buildPeek t p = ELam tvr $ createIO t (\tvrWorld -> EPrim (APrim (Peek p) mempty) [EVar tvrWorld,EVar tvr] (ltTuple [tWorld__,t]))  where
+    tvr =  (tVr 2 (tPtr t))
+buildPoke t p = ELam ptr_tvr $ ELam v_tvr $ createIO_ $ (\tw -> EPrim (APrim (Poke p) mempty) [EVar tw, EVar ptr_tvr, EVar v_tvr] tWorld__) where
+    ptr_tvr =  (tVr 2 (tPtr t))
+    v_tvr = tVr 4 t
+--toIO t x = prim_unsafeCoerce x (tIO t) 
+-}
+
+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 v t et@(ELit (LitCons cn' _ _)) = ELit (LitCons cn [ELit (LitInt v st)] et) where
+    st = ELit (LitCons (toName RawType t) [] eStar)
+    cn = toName DataConstructor $ nameName cn'
+    
+
+prim_const s t et@(ELit (LitCons cn' _ _)) =  eStrictLet (tVr 2 st) (EPrim (APrim (CConst s t) mempty) [] st) (ELit (LitCons cn [EVar $ tVr 2 st] et)) where
+    st = ELit (LitCons (toName RawType t) [] eStar)
+    cn = toName DataConstructor $ nameName cn'
+-- prim_const s t et = EPrim (APrim (CConst s t) mempty) [] et
+
addfile ./data/jhc_rts.c
hunk ./data/jhc_rts.c 1
+#include <stdlib.h>
+#define _GNU_SOURCE
+#include <stdio.h>
+#include <string.h>
+#include <unistd.h>
+#include <malloc.h>
+#define _GNU_SOURCE
+#include <wchar.h>
+#include <limits.h>
+#include <locale.h>
+#include <math.h>
+#include <float.h>
+
+#ifdef __GNUC__
+#define A_NORETURN __attribute__ ((noreturn))
+#define A_PURE __attribute__ ((pure))
+#define A_CONST __attribute__ ((const))
+#define A_UNUSED __attribute__ ((unused))
+#else
+#define A_NORETURN
+#define A_PURE
+#define A_CONST
+#define A_UNUSED
+#endif
+
+#define STR(s) #s
+#define XSTR(s) STR(s)
+
+static void XAmain();
+static int jhc_argc;
+static char **jhc_argv;
+static char *jhc_progname;
+
+static int jhc_stdrnd[2] A_UNUSED = { 1 , 1 };
+
+
+int 
+main(int argc, char *argv[]) 
+{ 
+        jhc_argc = argc - 1;
+        jhc_argv = argv + 1;
+        jhc_progname = argv[0];
+        setlocale(LC_ALL,"");
+        XAmain();
+        return 0; 
+}
+
+static void  A_NORETURN A_UNUSED
+jhc_error(char *s) { 
+    fputs(s,stderr); 
+    fputs("\n",stderr);
+    exit(255); 
+}
+
+static void  A_NORETURN A_UNUSED
+jhc_case_fell_off(int n) {
+        fflush(stdout);
+        fprintf(stderr, "\n%s:%i: case fell off\n", __FILE__, n); 
+        exit(32);
+}
+
+
+typedef union node node_t;
+
addfile ./data/operators.txt
hunk ./data/operators.txt 1
+
+
+
+[int,float,char,ptr] 
+aaB, ==, Prelude.Eq, ==
+# aaB, /=, Prelude.Eq, !=
+aaB, >=, Prelude.Ord, >=
+aaB, <=, Prelude.Ord, <=
+aaB, >, Prelude.Ord, >
+aaB, <, Prelude.Ord, <
+
+
+[int,float] 
+aaa, +, Prelude.Num, +
+aaa, -, Prelude.Num, -
+aaa, *, Prelude.Num, *
+aa, negate, Prelude.Num, -
+# 1, abs, Prelude.Num, abs
+# 1, signum, Prelude.Num, abs
+
+[int]
+aaa, .&., Data.Bits.Bits, &
+aaa, .|., Data.Bits.Bits, |
+aaa, xor, Data.Bits.Bits, ^
+aa, complement, Data.Bits,Bits, ~
+aaa, quot, Prelude.Integral, /
+aaa, rem, Prelude.Integral, %
+aaa, div, Prelude.Integral, /
+aaa, mod, Prelude.Integral, %
+aIa, shiftL, Data.Bits.Bits, <<
+aIa, shiftR, Data.Bits.Bits, >>
+
+
+# [float] 
+# aaa, /, Prelude.Fractional, /
+
addfile ./data/primitives.txt
hunk ./data/primitives.txt 1
+# Ideally, people should be able to declare these in the program.
+
+# limits.h, float.h, inttypes.h
+
+Prelude.Char, uint32_t, char, UINT32_MAX, 0
+Prelude.Int, int, int, INT_MAX, INT_MIN
+# Prelude.Integer, int, int, INT_MAX, INT_MIN
+Prelude.Integer, intmax_t, int, INTMAX_MAX, INTMAX_MIN
+
+Data.Int.Int8, int8_t, int, INT8_MAX, INT8_MIN
+Data.Int.Int16, int16_t, int, INT16_MAX, INT16_MIN 
+Data.Int.Int32, int32_t, int, INT32_MAX, INT32_MIN
+Data.Int.Int64, int64_t, int, INT64_MAX, INT64_MIN
+Data.Int.IntMax, intmax_t, int, INTMAX_MAX, INTMAX_MIN
+Data.Int.IntPtr, intptr_t, int, INTPTR_MAX, INTPTR_MIN
+
+Data.Word.Word, unsigned int, int, UINT_MAX, 0
+Data.Word.Word8, uint8_t, int, UINT8_MAX, 0
+Data.Word.Word16, uint16_t, int, UINT16_MAX, 0 
+Data.Word.Word32, uint32_t, int, UINT32_MAX, 0
+Data.Word.Word64, uint64_t, int, UINT64_MAX, 0
+Data.Word.WordMax, uintmax_t, int, UINTMAX_MAX, 0
+Data.Word.WordPtr, uintptr_t, int, UINTPTR_MAX, 0
+
+Prelude.Float, float, float, FLT_MAX, FLT_MIN
+Prelude.Double, double, float, DBL_MAX, DBL_MIN
+
+Jhc.Addr.Addr, HsPtr, ptr,UINTPTR_MAX, 0 
+Jhc.Addr.FunAddr, HsFunPtr, ptr,UINTPTR_MAX,0 
+
+Foreign.C.Types.CChar, char, int, CHAR_MAX, CHAR_MIN 
+Foreign.C.Types.CShort, short, int, SHORT_MAX, SHORT_MIN 
+Foreign.C.Types.CInt, int, int, INT_MAX, INT_MIN 
+Foreign.C.Types.CUInt, unsigned int, int, UINT_MAX, 0
+Foreign.C.Types.CSize, size_t, int, UINTPTR_MAX, 0
+Foreign.C.Types.CWchar, wchar_t, int, 0x10FFF, 0
+Foreign.C.Types.CWint, wint_t, int, 0x10FFF, 0
+
addfile ./docs/jhc.txt
hunk ./docs/jhc.txt 1
+= Jhc = 
+
+Jhc is a compiler for Haskell that aims to produce very efficient code as well as
+explore novel compilation techniques in an attempt to make them practical.
+
+One thing jhc does not aim to be is a toy or proof-of-concept compiler. A lot
+of the techniques have already had proof-of-concept implementations and jhc
+aims to determine how to bring them to a full-scale Haskell compiler. (or die
+trying)
+
+Although jhc is not ready for general use, I think some of its ideas or code
+might be useful to other people so I am deciding to release it in this state. 
+
+
+== Jhc Bullet Points ==
+
+* Full support for Haskell 98, The FFI and some extensions. (modulo some bugs
+being worked on and some libraries that need to be filled out) 
+
+* Produces 100% portable ISO C. The same C file can compile on machines of
+different byte order or bit-width without trouble.
+
+* No pre-written runtime. other than 20 lines of boilerplate all code is generated from
+the Grin intermediate code and subject to all code simplifying and dead code
+elimination transformations. As a result, jhc currently produces the smallest binaries of
+any Haskell compiler. (main = putStrLn "Hello, World!" compiles to
+6,568 bytes vs 177,120 bytes for GHC 6.4)
+
+* No garbage collector. A variant of Region Inference is in the works.
+
+* Compilation by transformation with 2 general intermediate languages. 
+
+* First Intermediate language based on Henk, Pure Type Systems and the Lambda
+cube. This is similar enough to GHCs core that many optimizations may be
+implemented in the same way.
+
+* Second Intermediate language is based on Boquist's graph reduction language.
+This allows all unknown jumps to be compiled out leaving standard case
+statements and function calls as the only form of flow control. Combined with
+jhc's use of region inference, this means jhc can compile to most any standard
+imperative architecture/language/virtual machine directly without special
+support for a stack or tail-calls.
+
+* Novel type class implementation not based on dictionary passing with many
+attractive properties. This implementation is possible due to the
+whole-program analysis phase and the use of the lambda-cube rather than System
+F as the base for the functional intermediate language.
+
+* Intermediate language and back-end suitable for directly compiling any language that can
+be embedded in the full lambda cube, making things like a compiler for
+cayenne much more direct. There is no type erasure phase, types are erased for
+the simple reason that values do not depend on them via the standard dead-code
+elimination pass.
+
+* A very modern design, it using rank-n polymorphism, monad transformers, generic
+programing, and existential types to make the code very concise and clear
+and improve code reuseability. (since jhc was written in pieces over 5 years, some at
+times when I just started using Haskell, the code quality actually varies a
+lot across the whole project)
+
+* All indirect jumps are transformed away, jhc's final code is very similar to
+hand-written imperitive code, using only branches and static function calls. A
+simple basic-blocks analysis is enough to transform tail-calls into loops. 
+
+* Full transparent support for mutually recursive modules.
+
+== More in depth == 
+
+
+=== Type Classes === 
+
+One of the most novel things about jhc is its implementation of type classes
+which differs significantly from the standard dictionary passing approach used
+by other Haskell compilers. 
+
+Jhc's unique approach is made possible by 2 other design choices, the use of a
+pure type system with no distinction between types and values and its use of
+whole-program analysis. The basic idea is that instead of passing a
+dictionary, a case statement directly scrutinizes the type parameter of a
+function and calls the appropriate overloaded routine directly. 
+
+This has a number of interesting properties
+
+* The number of extra hidden parameters is the number of free type variables
+in a functions signature rather than the number of class constraints. So (Ord
+a, Show a, Num a) => a -> a will only pass a single extra parameter for the
+type of a rather than 3 dictionaries.
+
+* 2 indirections, first one to look up the dictionary, then one to call the
+function pointed to in the dictionary are replaced by a single case of an
+algebraic data type and calls to statically known functions. This is exactly
+the transformation that the GRIN points-to analysis does, but much sooner and
+with much better optimization potential. Calls to statically known functions
+are MUCH more efficient. 
+
+* Standard case coalescing optimizations have a dramatically enhanced effect
+when dealing with overloaded functions. imagine the code snipped (x*(y + z)/z) :: a .
+Each of the calls to the polymorphic functions *, +, and / will expand
+to a case statement on 'a', since all case statements are trivially examining
+the same value, they are coalesced into a single one. With dictionary passing,
+we would have to look up the appropriate entry in the Num hidden parameter,
+the Floating hidden parameter, then look up each of *, +, and / individually.
+Under jhc's scheme all of that is statically  transformed into a single case
+on a normal algebraic type. This optimization is a HUGE win.  Jhc's ability to
+do this comes from the fact that it is  statically evident from that case
+statement that the type fully determines every polymorphic function on that
+type, a property that is lost in the dictionary passing approach since as far
+as the compiler is concerned, arbitrary functions may be being passed in the
+dictionaries, it does not know that they come in specific correlated sets.
+
+* Functional Dependencies actually lead to run-time savings. each functional
+dependency transforms into a case statement which may be omitted. 
+
+* Although a whole-world analysis is needed to generate full versions of
+type class methods, this is actually rarely needed in practice, as it is often
+the case the compiler is able to statically prove only a certain subset of
+types are needed at any given point and is able to generate specialized
+versions on the spot. This is implemented in a manner very similar to GHC's
+rules. 
+
+* Advanced compile-time and run-time specializations are possible via pragmas.
+(see below) 
+
+
+=== E ===
+
+E is a pure type system based on Henk and the lambda-cube. An important
+property of E is that there is no distinction between types and values, this
+is important for jhc's implementation of type classes.
+
+=== Grin ===
+
+Grin is basically a first-order monadic functional language. It is very
+similar to the Graph Reduction Intermediate Language as defined by Boquist but
+has a few notable changes.
+
+* It is typed. 
+
+* It has multiple return values as a primitive (unboxed tuples) 
+
+* My target is higher level C or C-- rather than RISC code, so some
+transformations are less important as the C compiler can be assumed to take
+care of them.
+
+* The terminology and syntax borrows from Haskell's current implementation of
+monads and 'do' notation.
+
+
+Most of the transformations mentioned in Boquist's thesis have
+been implemented, however certain intermediate states in Boquist's scheme are
+actually invalid in the strongly typed Grin of jhc so need to be combined or
+modified.
+
+A whole lot can be learned from the Grin data type and Grin is fully defined by the following  
+
+ infixr 1  :->, :>>=
+  
+ data Lam = Val :-> Exp
+    deriving(Eq,Ord,Show)
+  
+ data Exp =
+     Exp :>>= !Lam
+    | App Atom [Val]  -- ^ this handles applications of functions and built-ins
+    | Prim Primitive [Val]
+    | Case Val [Lam]
+    | Return { expValue :: Val }
+    | Store { expValue :: Val }
+    | Fetch { expAddress :: Val }
+    | Update { expAddress :: Val, expValue :: Val }
+    | Error String Ty -- ^ abort with an error message, non recoverably.
+    | Cast Val Ty     -- ^ reinterpret Val as a different type, also used to box\/unbox lifted types
+    deriving(Eq,Show,Ord)
+  
+ data Val =
+    NodeC !Tag [Val]
+    | NodeV !Var [Val]
+    | Tag !Tag
+    | Const Val         -- ^ pointer to constant data, only Lit, Tag, and NodeC may be children
+    | Lit !Number Ty
+    | Var !Var Ty
+    | Tup [Val]
+    | ValPrim APrim
+    deriving(Eq,Show,Ord)
+  
+ data Ty =
+    TyTag           -- ^ a lone tag
+    | TyPtr Ty      -- ^ pointer to a heap location which contains its argument
+    | TyNode        -- ^ a whole tagged node
+    | Ty Atom       -- ^ a basic type
+    | TyTup [Ty]    -- ^ unboxed list of values
+    | TyUnknown     -- ^ an unknown possibly undefined type, All of these must be eliminated by code generation
+    deriving(Eq,Ord)
+
+
+
+=== Extensions ===
+
+Jhc implements several extensions to Haskell 98
+
+==== Standard Extensions ====
+ 
+* The FFI is almost fully supported except for calling Haskell code from C.
+
+* Hierarchical module names are supported as described in the addendum. The
+  search algorithm is somewhat different than GHC though,
+  Control.Monad.Identity will be searched for as Control/Monad/Identity.hs,
+  Control/Monad.Identity.hs and Control.Monad.Identity.hs, giving you a bit more
+  freedom in laying out your directory structure.
+
+* Empty data declarations with no constructors are supported
+
+* Liberalized type synonyms are supported (type synonyms may appear anywhere
+  a type may appear)
+
+* INLINE, SPECIALIZE pragmas
+
+* unsafePerformIO, unsafeInterleaveIO are provided.
+
+==== New Extensions ====
+
+* Magic underscore. Using underscore in an expression expands to bottom with an error
+  message giving the current file and line number. This is useful because it
+  is common practice nowadays to use undefined as a witness for a type.
+  Relatively easy errors to make using this scheme lead to an unhelpful
+  "error: Prelude.undefined" with no indication of where the error actually is. By using the alternate <code>(_ :: Int)</code> rather than
+  <code>(undefined :: Int)</code> you will get an informative run-time error message as
+  well as save some space. The magic underscore is also useful as a
+  placeholder for code you mean to fill in later.
+
+* foreign primitive, all primitives are brought into scope with a foreign
+  primitive declaration (barring a few numeric operators) , these can also be
+  used to gain access to C constants, obviating much of the need for a
+  preprocessor such as hsc2hs and allowing portable C code to be generated by
+  jhc.
+
+* ERROR_ANNOTATE pragma. This is a generalization of GHCs assert magic. A
+  function which is given an ERROR_ANNOTATE pragma will be replaced with an
+  alternate version that takes the functions use site as an argument. This
+  allows error messages to be in terms of where said function was used. The
+  alternate function is named <code>[function]_err_ann__</code> and must be in 
+  the same module as the original function. Jhc does no checking to ensure both 
+  functions have the same effect, it is up to the user to ensure that. An
+  example is 
+
+<pre>
+
+  head :: [a] -> a
+  head (x:xs) = x
+  head [] = error "head - empty list"
+
+  {-# ERROR_ANNOTATE head #-}
+  
+  head_err_ann__ :: String -> [a] -> a
+  head_err_ann__ pos (x:xs) = x
+  head_err_ann__ pos [] = error $ pos ++ ": head - empty list"
+
+  -- Now, a call to head on an empty list will produce an error message like
+  -- "Main.hs:23: head - empty list"
+
+</pre>
+  
+  
+
+* SUPERSPECIALIZE pragma. This pragma has the same affect as the SPECIALIZE
+  pragma, but in addition to doing compile-time specialization,
+  SUPERSPECIALIZE performs run-time specialization. A superspecialized
+  function will perform a single check against the type it is called with and
+  depending on the single test, call a specialized version of the function.
+  This can be a huge win when working with overloaded numeric types, imagine a
+  matrix-multiply routine, if the type cannot be determined at compile-time then
+  we would normally be forced to fall back to generic version which may have
+  hundreds of additions and multiplications, each of which must test what type
+  its argument are. If we SUPERSPECIALIZE the multiply routine instead, a single
+  run-time test will be performed and the much much more efficient specialized
+  routine will be used, even if it could not be proven at compile time. 
+
+* MULTISPECIALIZE pragma. This is equivalent to calling SPECIALIZE against
+  every possible type. It's main cost is compile time and memory usage. It
+  should be used only sparingly as it can lead to quadratic rule explosion in
+  the total number of types in the transitive closure of all imported modules
+  in the worst case.
+
+* MULTISUPERSPECIALIZE pragma. This is equivalent to calling SUPERSPECIALIZE
+  against every possible type. If not careful, this can result in massive code
+  bloat but might be a big win in certain cases. 
+
+== The story of jhc ==
+
+When I first started to learn Haskell in 1999, I decided I needed a project.
+Haskell was my first (modern) functional language and I was seduced by its
+robust strong type system and efficiency gains. After writing a toy ray-tracer
+(my usual first project in a new language) it was clear I needed to try
+something somewhat more challenging and jhc was born. My reasoning was simple,
+by writing a Haskell compiler in Haskell I will double my language learning
+speed since I will not only have to learn how to program in it by forcing
+myself to complete a non-trivial project, but also its subtle semantics and
+dark corners since I actually needed to implement it correctly. Writing a
+compiler is also doubly efficient to begin with, since if you self-compile
+improvements not only give you a better optimizer, but also speed up your
+self-compiled compiler. All in all I figure I was making very good use of my
+time. For some reason, when I explain my reasoning to other people they look
+at me like I am crazy, but I can detect no flaw in my logic.
+
+In any case, I worked on jhc on and off for a while, the project got boosts a
+few times, such as when hatchet was released and I used it to replace my front
+end. 
+
+Recently, with my purchase of a faster machine actually beefy enough to run
+jhc and the realization I was getting good optimizations from my
+implementation of type classes combined with the small binary size of produced
+files I decided to make a push for jhc to become a usable compiler. 
+
+== All is not well in jhc-land ==
+
+There are still substantial issues which need to be overcome before jhc can be
+used for general Haskell programing
+
+* It doesn't scale. Basically since jhc compiles the entire standard library
+along with your code, even moderately complex programs can be beyond its
+grasp
+
+* It takes ridiculous amounts of memory and CPU. A gigabyte of RAM usage is
+not unheard of.
+
+* There are still some major bugs 
+
+* It leaks memory. The Region inference algorithm is still in the tweaking
+stage and programs are known to leak memory. for short running programs,
+this does not seem to be an issue, but anything expected to perform a lot of
+reductions will probably run out of heap.
+
+* it is not done
+
+* Arrays are very slow at the moment.
+
+* only about 70% of nofib compiles at the moment.
+
+* That said, I am releasing it because people might find the ideas interesting
+or be able to learn from or borrow of the code.
+
+* Horrible error messages. A few programmer errors (and some non-errors) cause the
+compiler to quit with an 'error' or pattern match failure.
+
+
+== References == 
+
+* Boquist Thesis
+
+* Henk paper
+
+* Pure Type Systems type checking paper
+
+* CPR analysis.
+
+* Strictness analysis w/ HORN clauses
+
+* Typing Haskell in Haskell
+
+* Hatchet
+
addfile ./docs/using.txt
hunk ./docs/using.txt 1
+= Using jhc =
+
+Installation of jhc involves building the jhc binary, placing it somewhere you
+can execute it and putting the libraries somewhere. 
+
+=== Building jhc ===
+
+building jhc requires the most recent version of DrIFT which can be gotten at
+http://repetae.net/john/computer/haskell/DrIFT/, GHC 6.4, happy, Perl, and having
+darcs will help keep updated with the newest version and submit patches.
+
+==== Getting the source ==== 
+
+Because jhc uses subrepositories, you need to use multiple darcs commands to
+pull everything needed to build jhc.
+
+  darcs get http://repetae.net/john/repos/jhc 
+  cd jhc
+  darcs get http://repetae.net/john/repos/Boolean 
+  darcs get http://repetae.net/john/repos/Doc
+
+==== making it ====
+
+Assuming you have ghc 6.4, happy, and DrIFT installed, you may now type 'make'
+and get a binary 'jhc' out if nothing went wrong.  
+
+=== Installing the libraries ====
+
+The jhc libraries will be in the 'lib' directory. these may be installed
+anywhere or left in place but the directory where they are installed *must be
+writable by the user of jhc* otherwise the compiler cannot create its
+intermediate files.
+
+Set the environment variable JHCPATH to the location of the library wherever
+you put it, or pass -l<dir> to jhc every time you call it so it can find the
+standard libraries.
+
+The first time you compile something, jhc will automatically create an
+optimized version of the standard libraries in 'ho' files next to their source
+code. This is why the library needs to be somewhere writable. Another effect
+being the first time you run jhc, it will take much longer than future runs.
+
+
+=== Running jhc ===
+
+jhc always runs in a mode similar to 'ghc --make' and will find all
+dependencies automatically. just run jhc on your file containing the Main module.  
+
+  jhc -v Main.hs 
+
+it is HIGHLY HIGHLY recommended you pass the '-v' flag to jhc. jhc takes a very
+long time to compile programs and without feedback you won't know if there is a
+problem. Much of the debugging output contains Unicode characters, it helps if
+your terminal is UTF8.
+
+While compiling, jhc will drop 'ho' files alongside your source code to speed
+up future compilation. feel free to delete these but having a set for the
+standard Haskell libraries pre-built will greatly speed up future builds.
+
+==== Options ====
+
+general options
+
+<include text `../jhc --help 2>&1`>
+
+things to pass to -d 
+
+<include text `../jhc -dhelp  2>&1`>
+
+things to pass to -f 
+
+<include text `../jhc -fhelp 2>&1 `>
+
+
addfile ./lib/Array.hs
hunk ./lib/Array.hs 1
+module  Array ( 
+    module Ix,  -- export all of Ix 
+    Array, array, listArray, (!), bounds, indices, elems, assocs, 
+    accumArray, (//), accum, ixmap ) where
+
+import Ix
+import List( (\\) )
+--import Prelude.Text
+
+infixl 9  !, //
+
+data (Ix a) => Array a b = MkArray (a,a) (a -> b) deriving ()
+
+array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+array b ivs =
+    if and [inRange b i | (i,_) <- ivs]
+        then MkArray b
+                     (\j -> case [v | (i,v) <- ivs, i == j] of
+                            [v]   -> v
+                            []    -> error "Array.!: \
+                                           \undefined array element"
+                            _     -> error "Array.!: \
+                                           \multiply defined array element")
+        else error "Array.array: out-of-range array association"
+
+listArray             :: (Ix a) => (a,a) -> [b] -> Array a b
+listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!)                   :: (Ix a) => Array a b -> a -> b
+(!) (MkArray _ f)     =  f
+
+bounds                :: (Ix a) => Array a b -> (a,a)
+bounds (MkArray b _)  =  b
+
+indices               :: (Ix a) => Array a b -> [a]
+indices               =  range . bounds
+
+elems                 :: (Ix a) => Array a b -> [b]
+elems a               =  [a!i | i <- indices a]
+
+assocs                :: (Ix a) => Array a b -> [(a,b)]
+assocs a              =  [(i, a!i) | i <- indices a]
+
+(//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+a // new_ivs          = array (bounds a) (old_ivs ++ new_ivs)
+                      where
+                  	old_ivs = [(i,a!i) | i <- indices a,
+                                             i `notElem` new_is]
+                  	new_is  = [i | (i,_) <- new_ivs]
+
+accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
+                                   -> Array a b
+accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
+                                   -> Array a b
+accumArray f z b      =  accum f (array b [(i,z) | i <- range b])
+
+ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
+                                         -> Array a c
+ixmap b f a           = array b [(i, a ! f i) | i <- range b]
+
+instance  (Ix a)          => Functor (Array a) where
+    fmap fn (MkArray b f) =  MkArray b (fn . f) 
+
+instance  (Ix a, Eq b)  => Eq (Array a b)  where
+    a == a' =  assocs a == assocs a'
+
+instance  (Ix a, Ord b) => Ord (Array a b)  where
+    a <= a' =  assocs a <= assocs a'
+
+instance  (Ix a, Show a, Show b) => Show (Array a b)  where
+    showsPrec p a = showParen (p > arrPrec) (
+                    showString "array " .
+                    showsPrec (arrPrec+1) (bounds a) . showChar ' ' .
+                    showsPrec (arrPrec+1) (assocs a)                  )
+
+instance  (Ix a, Read a, Read b) => Read (Array a b)  where
+    readsPrec p = readParen (p > arrPrec)
+           (\r -> [ (array b as, u) 
+                  | ("array",s) <- lex r,
+                    (b,t)       <- readsPrec (arrPrec+1) s,
+                    (as,u)      <- readsPrec (arrPrec+1) t ])
+
+-- Precedence of the 'array' function is that of application itself
+arrPrec :: Int
+arrPrec = 10
addfile ./lib/Char.hs
hunk ./lib/Char.hs 1
+module Char ( 
+    isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
+    isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+    digitToInt, intToDigit,
+    toUpper, toLower,
+    ord, chr,
+    readLitChar, showLitChar, lexLitChar,
+
+        -- ...and what the Prelude exports
+    Char, String
+    ) where
+
+--import Array         -- Used for character name table.
+import Numeric (readDec, readOct, lexDigits, readHex)
+import Prelude.Text
+
+-- Character-testing operations
+isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool
+
+isAscii c                =  c < '\x80'
+
+isLatin1 c               =  c <= '\xff'
+
+isControl c              =  c < ' ' || c >= '\DEL' && c <= '\x9f'
+
+isPrint c               =  isLatin1 c && not (isControl c) 
+
+isSpace c                =  c `elem` " \t\n\r\f\v\xA0"
+
+isUpper c                =  c >= 'A' && c <= 'Z'
+
+isLower c                =  c >= 'a' && c <= 'z'
+
+isAlpha c                =  isUpper c || isLower c
+
+isDigit c                =  c >= '0' && c <= '9'
+
+isOctDigit c             =  c >= '0' && c <= '7'
+
+isHexDigit c             =  isDigit c || c >= 'A' && c <= 'F' ||
+                                         c >= 'a' && c <= 'f'
+
+isAlphaNum c             =  isAlpha c || isDigit c
+
+
+-- Digit conversion operations
+digitToInt :: Char -> Int
+digitToInt c
+  | isDigit c            =  fromEnum c - fromEnum '0'
+  | c >= 'a' && c <= 'f' =  fromEnum c - fromEnum 'a' + 10
+  | c >= 'A' && c <= 'F' =  fromEnum c - fromEnum 'A' + 10
+  | otherwise            =  error "Char.digitToInt: not a digit"
+
+intToDigit :: Int -> Char
+intToDigit i
+  | i >= 0  && i <=  9   =  chr (ord '0' + i)
+  | i >= 10 && i <= 15   =  chr (ord 'a' + i - 10)
+  | otherwise            =  error "Char.intToDigit: not a digit"
+
+
+-- Case-changing operations
+toUpper :: Char -> Char
+toUpper c | isLower c = chr $ ord c - 32  
+          | otherwise = c
+        
+toLower :: Char -> Char
+toLower c | isUpper c = chr $ ord c + 32
+          | otherwise = c
+
+-- Character code functions
+--foreign import primitive ord :: Char -> Int
+--ord  =  fromEnum
+     
+--foreign import primitive chr :: Int  -> Char
+--chr  =  toEnum
+
+foreign import primitive "integralCast" ord :: Char -> Int
+foreign import primitive "integralCast" chr :: Int -> Char
+
+-- Text functions
+readLitChar          :: ReadS Char
+readLitChar ('\\':s) =  readEsc s
+readLitChar (c:s)    =  [(c,s)]
+
+readEsc          :: ReadS Char
+readEsc ('a':s)  = [('\a',s)]
+readEsc ('b':s)  = [('\b',s)]
+readEsc ('f':s)  = [('\f',s)]
+readEsc ('n':s)  = [('\n',s)]
+readEsc ('r':s)  = [('\r',s)]
+readEsc ('t':s)  = [('\t',s)]
+readEsc ('v':s)  = [('\v',s)]
+readEsc ('\\':s) = [('\\',s)]
+readEsc ('"':s)  = [('"',s)]
+readEsc ('\'':s) = [('\'',s)]
+readEsc ('^':(c:s)) | c >= '@' && c <= '_'
+                 = [(chr (ord c - ord '@'), s)]
+readEsc s@(d:_) | isDigit d
+                 = [(chr n, t) | (n,t) <- readDec s]
+readEsc ('o':s)  = [(chr n, t) | (n,t) <- readOct s]
+readEsc ('x':s)  = [(chr n, t) | (n,t) <- readHex s]
+readEsc s@(c:_) | isUpper c
+                 = let table = ('\DEL', "DEL") : zip ['\NUL' .. ] asciiTab
+                   in case [(c,s') | (c, mne) <- table,
+                                     ([],s') <- [match mne s]]
+                      of (pr:_) -> [pr]
+                         []     -> []
+readEsc _        = []
+
+match                         :: (Eq a) => [a] -> [a] -> ([a],[a])
+match (x:xs) (y:ys) | x == y  =  match xs ys
+match xs     ys               =  (xs,ys)
+
+showLitChar               :: Char -> ShowS
+showLitChar c | c > '\DEL' =  showChar '\\' . 
+                              protectEsc isDigit (shows (ord c))
+showLitChar '\DEL'         =  showString "\\DEL"
+showLitChar '\\'           =  showString "\\\\"
+showLitChar c | c >= ' '   =  showChar c
+showLitChar '\a'           =  showString "\\a"
+showLitChar '\b'           =  showString "\\b"
+showLitChar '\f'           =  showString "\\f"
+showLitChar '\n'           =  showString "\\n"
+showLitChar '\r'           =  showString "\\r"
+showLitChar '\t'           =  showString "\\t"
+showLitChar '\v'           =  showString "\\v"
+showLitChar '\SO'          =  protectEsc (== 'H') (showString "\\SO")
+showLitChar c              =  showString ('\\' : (asciiTab!!ord c))
+
+protectEsc p f             = f . cont
+                             where cont s@(c:_) | p c = "\\&" ++ s
+                                   cont s             = s
+
+asciiTab :: [String]                                   
+asciiTab = --listArray ('\NUL', ' ')
+           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI", 
+            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US", 
+            "SP"] 
+
+lexLitChar          :: ReadS String
+lexLitChar ('\\':s) =  map (prefix '\\') (lexEsc s)
+        where
+          lexEsc :: String -> [(String,String)]
+          lexEsc (c:s)     | c `elem` "abfnrtv\\\"'"  = [([c],s)]
+          lexEsc ('^':(c:s)) | (c >= '@') && (c <= '_') = [(['^',c],s)]
+
+          -- Numeric escapes
+          lexEsc ('o':s)               = [prefix 'o' (span isOctDigit s)]
+          lexEsc ('x':s)               = [prefix 'x' (span isHexDigit s)]
+          lexEsc s@(d:_)   | isDigit d = [span isDigit s]
+
+          -- Very crude approximation to \XYZ.
+          lexEsc s@(c:_)   | isUpper c = [span isCharName s]
+          lexEsc _                     = []
+
+          isCharName c   = isUpper c || isDigit c
+          prefix c (t,s) = (c:t, s)
+
+lexLitChar (c:s)    =  [([c],s)]
+lexLitChar ""       =  []
+
addfile ./lib/Complex.hs
hunk ./lib/Complex.hs 1
+module Complex(
+    Complex((:+)), 
+    realPart, 
+    imagPart, 
+    conjugate, 
+    mkPolar,
+    cis, 
+    polar, 
+    magnitude, 
+    phase
+    )  where
+
+infix  6  :+
+
+data  (RealFloat a)     => Complex a = !a :+ !a  deriving (Eq,Read,Show)
+
+
+realPart, imagPart :: (RealFloat a) => Complex a -> a
+realPart (x:+y)  =  x
+imagPart (x:+y)  =  y
+
+conjugate  :: (RealFloat a) => Complex a -> Complex a
+conjugate (x:+y) =  x :+ (-y)
+
+mkPolar  :: (RealFloat a) => a -> a -> Complex a
+mkPolar r theta  =  r * cos theta :+ r * sin theta
+
+cis  :: (RealFloat a) => a -> Complex a
+cis theta  =  cos theta :+ sin theta
+
+polar  :: (RealFloat a) => Complex a -> (a,a)
+polar z  =  (magnitude z, phase z)
+
+magnitude :: (RealFloat a) => Complex a -> a
+magnitude (x:+y) =  scaleFloat k
+     (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
+    where k  = max (exponent x) (exponent y)
+          mk = - k
+
+phase :: (RealFloat a) => Complex a -> a
+phase (0 :+ 0) = 0
+phase (x :+ y) = atan2 y x
+
+
+instance  (RealFloat a) => Num (Complex a)  where
+    (x:+y) + (x':+y') =  (x+x') :+ (y+y')
+    (x:+y) - (x':+y') =  (x-x') :+ (y-y')
+    (x:+y) * (x':+y') =  (x*x'-y*y') :+ (x*y'+y*x')
+    negate (x:+y) =  negate x :+ negate y
+    abs z =  magnitude z :+ 0
+    signum 0 =  0
+    signum z@(x:+y) =  x/r :+ y/r  where r = magnitude z
+    fromInteger n =  fromInteger n :+ 0
+
+instance  (RealFloat a) => Fractional (Complex a)  where
+    (x:+y) / (x':+y') =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
+       where x'' = scaleFloat k x'
+             y'' = scaleFloat k y'
+             k   = - max (exponent x') (exponent y')
+             d   = x'*x'' + y'*y''
+             fromRational a =  fromRational a :+ 0
+
+instance  (RealFloat a) => Floating (Complex a) where
+    pi             =  pi :+ 0
+    exp (x:+y)     =  expx * cos y :+ expx * sin y
+                      where expx = exp x
+    log z          =  log (magnitude z) :+ phase z
+
+    sqrt 0         =  0
+    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)
+                      where (u,v) = if x < 0 then (v',u') else (u',v')
+                            v'    = abs y / (u'*2)
+                            u'    = sqrt ((magnitude z + abs x) / 2)
+
+    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y
+    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)
+    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
+                      where sinx  = sin x
+                            cosx  = cos x
+                            sinhy = sinh y
+                            coshy = cosh y
+
+    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x
+    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x
+    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
+                      where siny  = sin y
+                            cosy  = cos y
+                            sinhx = sinh x
+                            coshx = cosh x
+
+    asin z@(x:+y)  =  y':+(-x')
+                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
+    acos z@(x:+y)  =  y'':+(-x'')
+                      where (x'':+y'') = log (z + ((-y'):+x'))
+                            (x':+y')   = sqrt (1 - z*z)
+    atan z@(x:+y)  =  y':+(-x')
+                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
+
+    asinh z        =  log (z + sqrt (1+z*z))
+    acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
+    atanh z        =  log ((1+z) / sqrt (1-z*z))
addfile ./lib/Data.Dynamic.hs
hunk ./lib/Data.Dynamic.hs 1
+module Data.Dynamic(Dynamic,toDyn,fromDyn,fromDynamic,dynApply,dynApp) where 
+
+
+import Data.Typeable
+
+data Obj 
+
+data Dynamic = Dynamic TypeRep Obj
+
+instance Show Dynamic where
+    showsPrec _ x s = "<Dynamic>" ++ s
+     
+-- | Converts an arbitrary value into an object of type 'Dynamic'.  
+--
+-- The type of the object must be an instance of 'Typeable', which
+-- ensures that only monomorphically-typed objects may be converted to
+-- 'Dynamic'.  To convert a polymorphic object into 'Dynamic', give it
+-- a monomorphic type signature.  For example:
+--
+-- >    toDyn (id :: Int -> Int)
+--
+toDyn :: Typeable a => a -> Dynamic
+toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
+
+-- | Converts a 'Dynamic' object back into an ordinary Haskell value of
+-- the correct type.  See also 'fromDynamic'.
+fromDyn :: Typeable a
+ 	=> Dynamic 	-- ^ the dynamically-typed object
+	-> a		-- ^ a default value 
+	-> a		-- ^ returns: the value of the first argument, if
+			-- it has the correct type, otherwise the value of
+			-- the second argument.
+fromDyn (Dynamic t v) def
+  | typeOf def == t = unsafeCoerce v
+  | otherwise       = def
+
+-- | Converts a 'Dynamic' object back into an ordinary Haskell value of
+-- the correct type.  See also 'fromDyn'.
+fromDynamic
+	:: Typeable a
+	=> Dynamic	-- ^ the dynamically-typed object
+	-> Maybe a	-- ^ returns: @'Just' a@, if the dynamically-typed
+			-- object has the correct type (and @a@ is its value), 
+			-- or 'Nothing' otherwise.
+fromDynamic (Dynamic t v) =
+  case unsafeCoerce v of 
+    r | t == typeOf r -> Just r
+      | otherwise     -> Nothing
+
+-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
+dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
+dynApply (Dynamic t1 f) (Dynamic t2 x) =
+  case funResultTy t1 t2 of
+    Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
+    Nothing -> Nothing
+
+dynApp :: Dynamic -> Dynamic -> Dynamic
+dynApp f x = case dynApply f x of 
+             Just r -> r
+             Nothing -> error ("Type error in dynamic application.\n" ++
+                               "Can't apply function " ++ show f ++
+                               " to argument " ++ show x)      
+
+
+foreign primitive "unsafeCoerce" unsafeCoerce :: a -> b
addfile ./lib/Data.IORef.hs
hunk ./lib/Data.IORef.hs 1
+module Data.IORef(
+    IORef,	      -- abstract, instance of: Eq
+    newIORef,	      -- :: a -> IO (IORef a)
+    readIORef,	      -- :: IORef a -> IO a
+    writeIORef,	      -- :: IORef a -> a -> IO ()
+    modifyIORef,      -- :: IORef a -> (a -> a) -> IO ()
+    atomicModifyIORef,-- :: IORef a -> (a -> (a,b)) -> IO b    
+    ) where
+
+import Prelude.IO
+
+data IORef a 
+
+foreign import primitive newIORef :: a -> IO (IORef a)
+foreign import primitive readIORef :: IORef a -> IO a
+foreign import primitive writeIORef :: IORef a -> a -> IO ()
+
+foreign import primitive eqIORef :: IORef a -> IORef a -> Bool
+
+instance Eq (IORef a) where
+    x == y = eqIORef x y
+    x /= y = not (eqIORef x y)
+
+modifyIORef :: IORef a -> (a -> a) -> IO ()
+modifyIORef ref f = writeIORef ref . f =<< readIORef ref
+
+atomicModifyIORef r f = do
+    a <- readIORef r
+    case f a of 
+        (a',b) -> writeIORef r a' >> return b  
addfile ./lib/Data.Typeable.hs
hunk ./lib/Data.Typeable.hs 1
+module Data.Typeable(TypeRep,typeOf) where
+
+
+data TypeRep 
+
+instance Eq TypeRep where
+    (==) = primTypeRepEq
+
+foreign import primitive typeOf :: a -> TypeRep
+foreign import primitive typeOf1 :: t a -> TypeRep
+foreign import primitive typeOf2 :: t a b -> TypeRep
+foreign import primitive typeOf3 :: t a b c -> TypeRep
+foreign import primitive typeOf4 :: t a b c d -> TypeRep
+foreign import primitive typeOf5 :: t a b c d e -> TypeRep
+foreign import primitive typeOf6 :: t a b c d e f -> TypeRep
+foreign import primitive typeOf7 :: t a b c d e f g -> TypeRep
+foreign import primitive typeRepEq :: TypeRep -> TypeRep -> Bool
+
+
+-------------------------------------------------------------
+--
+--		Type-safe cast
+--
+-------------------------------------------------------------
+
+-- | The type-safe cast operation
+cast ::  a -> Maybe b
+cast x = r
+       where
+	 r = if typeOf x == typeOf (fromJust r)
+               then Just $ unsafeCoerce x
+	       else Nothing
+
+-- | A flexible variation parameterised in a type constructor
+gcast :: c a -> Maybe (c b)
+gcast x = r
+ where
+  r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
+        then Just $ unsafeCoerce x
+        else Nothing
+  getArg :: c x -> x 
+  getArg = undefined
+
+-- | Cast for * -> *
+gcast1 ::  c (t a) -> Maybe (c (t' a)) 
+gcast1 x = r
+ where
+  r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
+       then Just $ unsafeCoerce x
+       else Nothing
+  getArg :: c x -> x 
+  getArg = undefined
+
+-- | Cast for * -> * -> *
+gcast2 ::  c (t a b) -> Maybe (c (t' a b)) 
+gcast2 x = r
+ where
+  r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
+       then Just $ unsafeCoerce x
+       else Nothing
+  getArg :: c x -> x 
+  getArg = undefined           
addfile ./lib/Data.Unicode.hs
hunk ./lib/Data.Unicode.hs 1
+module Data.Unicode where
+
+import Foreign.C.String
+
+newtype CType = CType Int
+
+-- | Get a ctype other than one of the defaults.
+
+ctype :: String -> IO CType
+ctype s = withCString s >>= c_wctype
+
+
+t_alnum, t_alpha, t_blank, t_cntrl, 
+ t_digit, t_graph, t_lower, t_print, 
+ t_punct, t_space, t_upper, t_xdigit, t_none :: CType
+
+t_alnum = unsafePerformIO (ctype "alnum")
+t_alpha = unsafePerformIO (ctype "alpha")
+t_blank = unsafePerformIO (ctype "blank")
+t_cntrl = unsafePerformIO (ctype "cntrl")
+t_digit = unsafePerformIO (ctype "digit")
+t_graph = unsafePerformIO (ctype "graph")
+t_lower = unsafePerformIO (ctype "lower")
+t_print = unsafePerformIO (ctype "print")
+t_punct = unsafePerformIO (ctype "punct")
+t_space = unsafePerformIO (ctype "space")
+t_upper = unsafePerformIO (ctype "upper")
+t_xdigit = unsafePerformIO (ctype "xdigit")
+t_none = CType 0
+
+
+
+foreign import ccall "wctype.h iswctype" c_iswctype :: Char -> CType -> IO Int
+foreign import ccall "wctype.h wctype" c_wctype :: CString -> IO CType
+
addfile ./lib/Data/Bits.hs
hunk ./lib/Data/Bits.hs 1
+module Data.Bits where 
+
+
+
+infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
+infixl 7 .&.
+infixl 6 `xor`
+infixl 5 .|.   
+
+
+{-| 
+The 'Bits' class defines bitwise operations over integral types.
+
+* Bits are numbered from 0 with bit 0 being the least
+  significant bit.
+-}
+class Num a => Bits a where
+    -- | Bitwise \"and\"
+    (.&.) :: a -> a -> a
+
+    -- | Bitwise \"or\"
+    (.|.) :: a -> a -> a
+
+    -- | Bitwise \"xor\"
+    xor :: a -> a -> a
+
+    {-| Reverse all the bits in the argument -}
+    complement        :: a -> a
+
+    {-| Shift the argument left by the specified number of bits.
+	Right shifts (signed) are specified by giving a negative value.
+
+	An instance can define either this unified 'shift' or 'shiftL' and
+	'shiftR', depending on which is more convenient for the type in
+	question. -}
+    shift             :: a -> Int -> a
+
+    x `shift`   i | i<0  = x `shiftR` (-i)
+                  | i==0 = x
+                  | i>0  = x `shiftL` i
+
+    {-| Rotate the argument left by the specified number of bits.
+	Right rotates are specified by giving a negative value.
+
+        For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.
+
+	An instance can define either this unified 'rotate' or 'rotateL' and
+	'rotateR', depending on which is more convenient for the type in
+	question. -}
+    rotate            :: a -> Int -> a
+
+    x `rotate`  i | i<0  = x `rotateR` (-i)
+                  | i==0 = x
+                  | i>0  = x `rotateL` i
+
+    {-
+    -- Rotation can be implemented in terms of two shifts, but care is
+    -- needed for negative values.  This suggested implementation assumes
+    -- 2's-complement arithmetic.  It is commented out because it would
+    -- require an extra context (Ord a) on the signature of 'rotate'.
+    x `rotate`  i | i<0 && isSigned x && x<0
+                         = let left = i+bitSize x in
+                           ((x `shift` i) .&. complement ((-1) `shift` left))
+                           .|. (x `shift` left)
+                  | i<0  = (x `shift` i) .|. (x `shift` (i+bitSize x))
+                  | i==0 = x
+                  | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))
+    -}
+
+    -- | @bit i@ is a value with the @i@th bit set
+    bit               :: Int -> a
+
+    -- | @x \`setBit\` i@ is the same as @x .|. bit i@
+    setBit            :: a -> Int -> a
+
+    -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@
+    clearBit          :: a -> Int -> a
+
+    -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@
+    complementBit     :: a -> Int -> a
+
+    -- | Return 'True' if the @n@th bit of the argument is 1
+    testBit           :: a -> Int -> Bool
+
+    {-| Return the number of bits in the type of the argument.  The actual
+	value of the argument is ignored.  The function 'bitSize' is
+	undefined for types that do not have a fixed bitsize, like 'Integer'.
+	-}
+    bitSize           :: a -> Int
+
+    {-| Return 'True' if the argument is a signed type.  The actual
+        value of the argument is ignored -}
+    isSigned          :: a -> Bool
+
+    bit i               = 1 `shiftL` i
+    x `setBit` i        = x .|. bit i
+    x `clearBit` i      = x .&. complement (bit i)
+    x `complementBit` i = x `xor` bit i
+    x `testBit` i       = (x .&. bit i) /= 0
+
+    {-| Shift the argument left by the specified number of bits
+	(which must be non-negative).
+
+	An instance can define either this and 'shiftR' or the unified
+	'shift', depending on which is more convenient for the type in
+	question. -}
+    shiftL            :: a -> Int -> a
+    x `shiftL`  i = x `shift`  i
+
+    {-| Shift the argument right (signed) by the specified number of bits
+	(which must be non-negative).
+
+	An instance can define either this and 'shiftL' or the unified
+	'shift', depending on which is more convenient for the type in
+	question. -}
+    shiftR            :: a -> Int -> a
+    x `shiftR`  i = x `shift`  (-i)
+
+    {-| Rotate the argument left by the specified number of bits
+	(which must be non-negative).
+
+	An instance can define either this and 'rotateR' or the unified
+	'rotate', depending on which is more convenient for the type in
+	question. -}
+    rotateL           :: a -> Int -> a
+    x `rotateL` i = x `rotate` i
+
+    {-| Rotate the argument right by the specified number of bits
+	(which must be non-negative).
+
+	An instance can define either this and 'rotateL' or the unified
+	'rotate', depending on which is more convenient for the type in
+	question. -}
+    rotateR           :: a -> Int -> a
+    x `rotateR` i = x `rotate` (-i)     
+
+
addfile ./lib/Data/Int.hs
hunk ./lib/Data/Int.hs 1
+module Data.Int(Int,Int8,Int16,Int32,Int64,IntMax,IntPtr) where
+
+
+data Int8
+data Int16
+data Int32
+data Int64
+data IntMax
+data IntPtr
addfile ./lib/Data/Monoid.hs
hunk ./lib/Data/Monoid.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Monoid
+-- Copyright   :  (c) Andy Gill 2001,
+-- 		  (c) Oregon Graduate Institute of Science and Technology, 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (requires extended type classes)
+--
+-- Declaration of the Monoid class, and instances for list and functions.
+--
+--	  Inspired by the paper
+--	  /Functional Programming with Overloading and
+--	      Higher-Order Polymorphism/, 
+--	    Mark P Jones (<http://www.cse.ogi.edu/~mpj/>)
+--		  Advanced School of Functional Programming, 1995.
+-----------------------------------------------------------------------------
+
+module Data.Monoid (
+ 	Monoid(..)
+  ) where
+
+import Prelude
+
+-- ---------------------------------------------------------------------------
+-- | The monoid class.
+-- A minimal complete definition must supply 'mempty' and 'mappend',
+-- and these should satisfy the monoid laws.
+
+class Monoid a where
+	mempty  :: a
+	-- ^ Identity of 'mappend'
+	mappend :: a -> a -> a
+	-- ^ An associative operation
+	mconcat :: [a] -> a
+
+	-- ^ Fold a list using the monoid.
+	-- For most types, the default definition for 'mconcat' will be
+	-- used, but the function is included in the class definition so
+	-- that an optimized version can be provided for specific types.
+
+	mconcat = foldr mappend mempty
+
+-- Monoid instances.
+
+instance Monoid [a] where
+	mempty  = []
+	mappend = (++)
+
+instance Monoid (a -> a) where
+	mempty  = id
+	mappend = (.)
+
+instance Monoid () where
+	-- Should it be strict?
+	mempty        = ()
+	_ `mappend` _ = ()
+	mconcat _     = ()
+
+instance (Monoid a, Monoid b) => Monoid (a,b) where
+	mempty = (mempty, mempty)
+	(a1,b1) `mappend` (a2,b2) =
+		(a1 `mappend` a2, b1 `mappend` b2)
+
+instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+	mempty = (mempty, mempty, mempty)
+	(a1,b1,c1) `mappend` (a2,b2,c2) =
+		(a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
+	mempty = (mempty, mempty, mempty, mempty)
+	(a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
+		(a1 `mappend` a2, b1 `mappend` b2,
+		 c1 `mappend` c2, d1 `mappend` d2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
+		Monoid (a,b,c,d,e) where
+	mempty = (mempty, mempty, mempty, mempty, mempty)
+	(a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
+		(a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
+		 d1 `mappend` d2, e1 `mappend` e2)
+
+-- lexicographical ordering
+instance Monoid Ordering where
+	mempty         = EQ
+	LT `mappend` _ = LT
+	EQ `mappend` y = y
+	GT `mappend` _ = GT
addfile ./lib/Data/Word.hs
hunk ./lib/Data/Word.hs 1
+{-# OPTIONS -N #-}
+module Data.Word(Word,Word8,Word16,Word32,Word64,WordMax,WordPtr) where
+
+
+
+data Word
+data Word8
+data Word16
+data Word32
+data Word64
+data WordMax
+data WordPtr
addfile ./lib/Directory.hs
hunk ./lib/Directory.hs 1
+module Directory ( 
+    Permissions( Permissions, readable, writable, executable, searchable ), 
+    createDirectory, removeDirectory, removeFile, 
+    renameDirectory, renameFile, getDirectoryContents,
+    getCurrentDirectory, setCurrentDirectory,
+    doesFileExist, doesDirectoryExist,
+    getPermissions, setPermissions,
+    getModificationTime ) where
+
+import Time ( ClockTime )
+
+data Permissions = Permissions {
+    readable,   writable,
+    executable, searchable :: Bool
+   } deriving (Eq,Ord,Read,Show)
+
+
+
+
+createDirectory  :: FilePath -> IO ()
+removeDirectory  :: FilePath -> IO ()
+removeFile  :: FilePath -> IO ()
+renameDirectory  :: FilePath -> FilePath -> IO ()
+renameFile  :: FilePath -> FilePath -> IO ()
+
+getDirectoryContents  :: FilePath -> IO [FilePath]
+getCurrentDirectory  :: IO FilePath
+setCurrentDirectory  :: FilePath -> IO ()
+
+doesFileExist :: FilePath -> IO Bool
+doesDirectoryExist :: FilePath -> IO Bool
+
+getPermissions :: FilePath -> IO Permissions
+setPermissions :: FilePath -> Permissions -> IO ()
+
+getModificationTime :: FilePath -> IO ClockTime
+
+
addfile ./lib/Foreign/C/Error.hs
hunk ./lib/Foreign/C/Error.hs 1
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Foreign.C.Error
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- C-specific Marshalling support: Handling of C \"errno\" error codes.
+--
+-----------------------------------------------------------------------------
+
+
+
+module Foreign.C.Error (
+
+  -- * Haskell representations of @errno@ values
+
+  Errno(..),		-- instance: Eq
+
+  -- ** Common @errno@ symbols
+  -- | Different operating systems and\/or C libraries often support
+  -- different values of @errno@.  This module defines the common values,
+  -- but due to the open definition of 'Errno' users may add definitions
+  -- which are not predefined.
+  eOK,{- e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, 
+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, 
+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, 
+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, 
+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, 
+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, 
+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, 
+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, 
+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, 
+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, 
+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, 
+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, 
+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, 
+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV, -}
+
+  -- ** 'Errno' functions
+                        -- :: Errno
+  isValidErrno,		-- :: Errno -> Bool
+
+  -- access to the current thread's "errno" value
+  --
+  getErrno,             -- :: IO Errno
+  resetErrno,           -- :: IO ()
+
+  -- conversion of an "errno" value into IO error
+  --
+  errnoToIOError,       -- :: String       -- location
+                        -- -> Errno        -- errno
+                        -- -> Maybe Handle -- handle
+                        -- -> Maybe String -- filename
+                        -- -> IOError
+
+  -- throw current "errno" value
+  --
+  throwErrno,           -- ::                String               -> IO a
+
+  -- ** Guards for IO operations that may fail
+
+  throwErrnoIf,         -- :: (a -> Bool) -> String -> IO a       -> IO a
+  throwErrnoIf_,        -- :: (a -> Bool) -> String -> IO a       -> IO ()
+  throwErrnoIfRetry,    -- :: (a -> Bool) -> String -> IO a       -> IO a
+  throwErrnoIfRetry_,   -- :: (a -> Bool) -> String -> IO a       -> IO ()
+  throwErrnoIfMinus1,   -- :: Num a 
+			-- =>                String -> IO a       -> IO a
+  throwErrnoIfMinus1_,  -- :: Num a 
+			-- =>                String -> IO a       -> IO ()
+  throwErrnoIfMinus1Retry,  
+			-- :: Num a 
+			-- =>                String -> IO a       -> IO a
+  throwErrnoIfMinus1Retry_,  
+			-- :: Num a 
+			-- =>                String -> IO a       -> IO ()
+  throwErrnoIfNull,	-- ::                String -> IO (Ptr a) -> IO (Ptr a)
+  throwErrnoIfNullRetry,-- ::                String -> IO (Ptr a) -> IO (Ptr a)
+
+  throwErrnoIfRetryMayBlock, 
+  throwErrnoIfRetryMayBlock_,
+  throwErrnoIfMinus1RetryMayBlock,
+  throwErrnoIfMinus1RetryMayBlock_,  
+  throwErrnoIfNullRetryMayBlock
+) where
+
+
+import Foreign.Storable
+import Foreign.Ptr
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Marshal.Error 	( void )
+
+import System.IO.Unsafe		( unsafePerformIO )
+
+
+
+-- "errno" type
+-- ------------
+
+-- | Haskell representation for @errno@ values.
+-- The implementation is deliberately exposed, to allow users to add
+-- their own definitions of 'Errno' values.
+
+newtype Errno = Errno CInt
+
+instance Eq Errno where
+  errno1@(Errno no1) == errno2@(Errno no2) 
+    | isValidErrno errno1 && isValidErrno errno2 = no1 == no2
+    | otherwise					 = False
+
+-- common "errno" symbols
+--
+{-
+eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, 
+  eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, 
+  eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, 
+  eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, 
+  eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, 
+  eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, 
+  eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, 
+  eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, 
+  eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, 
+  eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, 
+  ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, 
+  eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, 
+  eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, 
+  eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV		       :: Errno
+-- -}
+-- the cCONST_XXX identifiers are cpp symbols whose value is computed by
+-- configure 
+--
+eOK             = Errno 0
+{-
+#ifdef __NHC__
+#include "Errno.hs"
+#else
+e2BIG           = Errno (CONST_E2BIG)
+eACCES		= Errno (CONST_EACCES)
+eADDRINUSE	= Errno (CONST_EADDRINUSE)
+eADDRNOTAVAIL	= Errno (CONST_EADDRNOTAVAIL)
+eADV		= Errno (CONST_EADV)
+eAFNOSUPPORT	= Errno (CONST_EAFNOSUPPORT)
+eAGAIN		= Errno (CONST_EAGAIN)
+eALREADY	= Errno (CONST_EALREADY)
+eBADF		= Errno (CONST_EBADF)
+eBADMSG		= Errno (CONST_EBADMSG)
+eBADRPC		= Errno (CONST_EBADRPC)
+eBUSY		= Errno (CONST_EBUSY)
+eCHILD		= Errno (CONST_ECHILD)
+eCOMM		= Errno (CONST_ECOMM)
+eCONNABORTED	= Errno (CONST_ECONNABORTED)
+eCONNREFUSED	= Errno (CONST_ECONNREFUSED)
+eCONNRESET	= Errno (CONST_ECONNRESET)
+eDEADLK		= Errno (CONST_EDEADLK)
+eDESTADDRREQ	= Errno (CONST_EDESTADDRREQ)
+eDIRTY		= Errno (CONST_EDIRTY)
+eDOM		= Errno (CONST_EDOM)
+eDQUOT		= Errno (CONST_EDQUOT)
+eEXIST		= Errno (CONST_EEXIST)
+eFAULT		= Errno (CONST_EFAULT)
+eFBIG		= Errno (CONST_EFBIG)
+eFTYPE		= Errno (CONST_EFTYPE)
+eHOSTDOWN	= Errno (CONST_EHOSTDOWN)
+eHOSTUNREACH	= Errno (CONST_EHOSTUNREACH)
+eIDRM		= Errno (CONST_EIDRM)
+eILSEQ		= Errno (CONST_EILSEQ)
+eINPROGRESS	= Errno (CONST_EINPROGRESS)
+eINTR		= Errno (CONST_EINTR)
+eINVAL		= Errno (CONST_EINVAL)
+eIO		= Errno (CONST_EIO)
+eISCONN		= Errno (CONST_EISCONN)
+eISDIR		= Errno (CONST_EISDIR)
+eLOOP		= Errno (CONST_ELOOP)
+eMFILE		= Errno (CONST_EMFILE)
+eMLINK		= Errno (CONST_EMLINK)
+eMSGSIZE	= Errno (CONST_EMSGSIZE)
+eMULTIHOP	= Errno (CONST_EMULTIHOP)
+eNAMETOOLONG	= Errno (CONST_ENAMETOOLONG)
+eNETDOWN	= Errno (CONST_ENETDOWN)
+eNETRESET	= Errno (CONST_ENETRESET)
+eNETUNREACH	= Errno (CONST_ENETUNREACH)
+eNFILE		= Errno (CONST_ENFILE)
+eNOBUFS		= Errno (CONST_ENOBUFS)
+eNODATA		= Errno (CONST_ENODATA)
+eNODEV		= Errno (CONST_ENODEV)
+eNOENT		= Errno (CONST_ENOENT)
+eNOEXEC		= Errno (CONST_ENOEXEC)
+eNOLCK		= Errno (CONST_ENOLCK)
+eNOLINK		= Errno (CONST_ENOLINK)
+eNOMEM		= Errno (CONST_ENOMEM)
+eNOMSG		= Errno (CONST_ENOMSG)
+eNONET		= Errno (CONST_ENONET)
+eNOPROTOOPT	= Errno (CONST_ENOPROTOOPT)
+eNOSPC		= Errno (CONST_ENOSPC)
+eNOSR		= Errno (CONST_ENOSR)
+eNOSTR		= Errno (CONST_ENOSTR)
+eNOSYS		= Errno (CONST_ENOSYS)
+eNOTBLK		= Errno (CONST_ENOTBLK)
+eNOTCONN	= Errno (CONST_ENOTCONN)
+eNOTDIR		= Errno (CONST_ENOTDIR)
+eNOTEMPTY	= Errno (CONST_ENOTEMPTY)
+eNOTSOCK	= Errno (CONST_ENOTSOCK)
+eNOTTY		= Errno (CONST_ENOTTY)
+eNXIO		= Errno (CONST_ENXIO)
+eOPNOTSUPP	= Errno (CONST_EOPNOTSUPP)
+ePERM		= Errno (CONST_EPERM)
+ePFNOSUPPORT	= Errno (CONST_EPFNOSUPPORT)
+ePIPE		= Errno (CONST_EPIPE)
+ePROCLIM	= Errno (CONST_EPROCLIM)
+ePROCUNAVAIL	= Errno (CONST_EPROCUNAVAIL)
+ePROGMISMATCH	= Errno (CONST_EPROGMISMATCH)
+ePROGUNAVAIL	= Errno (CONST_EPROGUNAVAIL)
+ePROTO		= Errno (CONST_EPROTO)
+ePROTONOSUPPORT = Errno (CONST_EPROTONOSUPPORT)
+ePROTOTYPE	= Errno (CONST_EPROTOTYPE)
+eRANGE		= Errno (CONST_ERANGE)
+eREMCHG		= Errno (CONST_EREMCHG)
+eREMOTE		= Errno (CONST_EREMOTE)
+eROFS		= Errno (CONST_EROFS)
+eRPCMISMATCH	= Errno (CONST_ERPCMISMATCH)
+eRREMOTE	= Errno (CONST_ERREMOTE)
+eSHUTDOWN	= Errno (CONST_ESHUTDOWN)
+eSOCKTNOSUPPORT = Errno (CONST_ESOCKTNOSUPPORT)
+eSPIPE		= Errno (CONST_ESPIPE)
+eSRCH		= Errno (CONST_ESRCH)
+eSRMNT		= Errno (CONST_ESRMNT)
+eSTALE		= Errno (CONST_ESTALE)
+eTIME		= Errno (CONST_ETIME)
+eTIMEDOUT	= Errno (CONST_ETIMEDOUT)
+eTOOMANYREFS	= Errno (CONST_ETOOMANYREFS)
+eTXTBSY		= Errno (CONST_ETXTBSY)
+eUSERS		= Errno (CONST_EUSERS)
+eWOULDBLOCK	= Errno (CONST_EWOULDBLOCK)
+eXDEV		= Errno (CONST_EXDEV)
+#endif
+-}
+-- | Yield 'True' if the given 'Errno' value is valid on the system.
+-- This implies that the 'Eq' instance of 'Errno' is also system dependent
+-- as it is only defined for valid values of 'Errno'.
+--
+isValidErrno               :: Errno -> Bool
+--
+-- the configure script sets all invalid "errno"s to -1
+--
+isValidErrno (Errno errno)  = errno /= -1
+
+
+-- access to the current thread's "errno" value
+-- --------------------------------------------
+
+-- | Get the current value of @errno@ in the current thread.
+--
+getErrno :: IO Errno
+
+-- We must call a C function to get the value of errno in general.  On
+-- threaded systems, errno is hidden behind a C macro so that each OS
+-- thread gets its own copy.
+getErrno = do e <- peek _errno; return (Errno e)
+foreign import ccall "errno.h &errno" _errno :: Ptr CInt
+
+-- | Reset the current thread\'s @errno@ value to 'eOK'.
+--
+resetErrno :: IO ()
+
+-- Again, setting errno has to be done via a C function.
+resetErrno = poke _errno 0
+
+-- throw current "errno" value
+-- ---------------------------
+
+-- | Throw an 'IOError' corresponding to the current value of 'getErrno'.
+--
+throwErrno     :: String	-- ^ textual description of the error location
+	       -> IO a
+throwErrno loc  =
+  do
+    errno <- getErrno
+    ioError (errnoToIOError loc errno Nothing Nothing)
+
+
+-- guards for IO operations that may fail
+-- --------------------------------------
+
+-- | Throw an 'IOError' corresponding to the current value of 'getErrno'
+-- if the result value of the 'IO' action meets the given predicate.
+--
+throwErrnoIf    :: (a -> Bool)	-- ^ predicate to apply to the result value
+				-- of the 'IO' operation
+		-> String	-- ^ textual description of the location
+		-> IO a		-- ^ the 'IO' operation to be executed
+		-> IO a
+throwErrnoIf pred loc f  = 
+  do
+    res <- f
+    if pred res then throwErrno loc else return res
+
+-- | as 'throwErrnoIf', but discards the result of the 'IO' action after
+-- error handling.
+--
+throwErrnoIf_   :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIf_ pred loc f  = void $ throwErrnoIf pred loc f
+
+-- | as 'throwErrnoIf', but retry the 'IO' action when it yields the
+-- error code 'eINTR' - this amounts to the standard retry loop for
+-- interrupted POSIX system calls.
+--
+throwErrnoIfRetry            :: (a -> Bool) -> String -> IO a -> IO a
+throwErrnoIfRetry pred loc f  = 
+  do
+    res <- f
+    if pred res
+      then do
+	err <- getErrno
+	if err == eINTR
+	  then throwErrnoIfRetry pred loc f
+	  else throwErrno loc
+      else return res
+
+-- | as 'throwErrnoIfRetry', but checks for operations that would block and
+-- executes an alternative action before retrying in that case.
+--
+throwErrnoIfRetryMayBlock
+		:: (a -> Bool)	-- ^ predicate to apply to the result value
+				-- of the 'IO' operation
+		-> String	-- ^ textual description of the location
+		-> IO a		-- ^ the 'IO' operation to be executed
+		-> IO b		-- ^ action to execute before retrying if
+				-- an immediate retry would block
+		-> IO a
+throwErrnoIfRetryMayBlock pred loc f on_block  = 
+  do
+    res <- f
+    if pred res
+      then do
+	err <- getErrno
+	if err == eINTR
+	  then throwErrnoIfRetryMayBlock pred loc f on_block
+          else if err == eWOULDBLOCK || err == eAGAIN
+	         then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block
+                 else throwErrno loc
+      else return res
+
+-- | as 'throwErrnoIfRetry', but discards the result.
+--
+throwErrnoIfRetry_            :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIfRetry_ pred loc f  = void $ throwErrnoIfRetry pred loc f
+
+-- | as 'throwErrnoIfRetryMayBlock', but discards the result.
+--
+throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO ()
+throwErrnoIfRetryMayBlock_ pred loc f on_block 
+  = void $ throwErrnoIfRetryMayBlock pred loc f on_block
+
+-- | Throw an 'IOError' corresponding to the current value of 'getErrno'
+-- if the 'IO' action returns a result of @-1@.
+--
+throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1  = throwErrnoIf (== -1)
+
+-- | as 'throwErrnoIfMinus1', but discards the result.
+--
+throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)
+
+-- | Throw an 'IOError' corresponding to the current value of 'getErrno'
+-- if the 'IO' action returns a result of @-1@, but retries in case of
+-- an interrupted operation.
+--
+throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)
+
+-- | as 'throwErrnoIfMinus1', but discards the result.
+--
+throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)
+
+-- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.
+--
+throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
+throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)
+
+-- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.
+--
+throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
+throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)
+
+-- | Throw an 'IOError' corresponding to the current value of 'getErrno'
+-- if the 'IO' action returns 'nullPtr'.
+--
+throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNull  = throwErrnoIf (== nullPtr)
+
+-- | Throw an 'IOError' corresponding to the current value of 'getErrno'
+-- if the 'IO' action returns 'nullPtr',
+-- but retry in case of an interrupted operation.
+--
+throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a)
+throwErrnoIfNullRetry  = throwErrnoIfRetry (== nullPtr)
+
+-- | as 'throwErrnoIfNullRetry', but checks for operations that would block.
+--
+throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a)
+throwErrnoIfNullRetryMayBlock  = throwErrnoIfRetryMayBlock (== nullPtr)
+
+-- conversion of an "errno" value into IO error
+-- --------------------------------------------
+
+-- | Construct a Haskell 98 I\/O error based on the given 'Errno' value.
+-- The optional information can be used to improve the accuracy of
+-- error messages.
+--
+errnoToIOError	:: String	-- ^ the location where the error occurred
+		-> Errno	-- ^ the error number
+		-> Maybe a	-- ^ optional handle associated with the error
+		-> Maybe String	-- ^ optional filename associated with the error
+		-> IOError
+errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do
+    str <- strerror errno >>= peekCString
+
+{-
+#if __GLASGOW_HASKELL__
+    return (IOError maybeHdl errType loc str maybeName)
+    where
+    errType
+        | errno == eOK             = OtherError
+        | errno == e2BIG           = ResourceExhausted
+        | errno == eACCES          = PermissionDenied
+        | errno == eADDRINUSE      = ResourceBusy
+        | errno == eADDRNOTAVAIL   = UnsupportedOperation
+        | errno == eADV            = OtherError
+        | errno == eAFNOSUPPORT    = UnsupportedOperation
+        | errno == eAGAIN          = ResourceExhausted
+        | errno == eALREADY        = AlreadyExists
+        | errno == eBADF           = OtherError
+        | errno == eBADMSG         = InappropriateType
+        | errno == eBADRPC         = OtherError
+        | errno == eBUSY           = ResourceBusy
+        | errno == eCHILD          = NoSuchThing
+        | errno == eCOMM           = ResourceVanished
+        | errno == eCONNABORTED    = OtherError
+        | errno == eCONNREFUSED    = NoSuchThing
+        | errno == eCONNRESET      = ResourceVanished
+        | errno == eDEADLK         = ResourceBusy
+        | errno == eDESTADDRREQ    = InvalidArgument
+        | errno == eDIRTY          = UnsatisfiedConstraints
+        | errno == eDOM            = InvalidArgument
+        | errno == eDQUOT          = PermissionDenied
+        | errno == eEXIST          = AlreadyExists
+        | errno == eFAULT          = OtherError
+        | errno == eFBIG           = PermissionDenied
+        | errno == eFTYPE          = InappropriateType
+        | errno == eHOSTDOWN       = NoSuchThing
+        | errno == eHOSTUNREACH    = NoSuchThing
+        | errno == eIDRM           = ResourceVanished
+        | errno == eILSEQ          = InvalidArgument
+        | errno == eINPROGRESS     = AlreadyExists
+        | errno == eINTR           = Interrupted
+        | errno == eINVAL          = InvalidArgument
+        | errno == eIO             = HardwareFault
+        | errno == eISCONN         = AlreadyExists
+        | errno == eISDIR          = InappropriateType
+        | errno == eLOOP           = InvalidArgument
+        | errno == eMFILE          = ResourceExhausted
+        | errno == eMLINK          = ResourceExhausted
+        | errno == eMSGSIZE        = ResourceExhausted
+        | errno == eMULTIHOP       = UnsupportedOperation
+        | errno == eNAMETOOLONG    = InvalidArgument
+        | errno == eNETDOWN        = ResourceVanished
+        | errno == eNETRESET       = ResourceVanished
+        | errno == eNETUNREACH     = NoSuchThing
+        | errno == eNFILE          = ResourceExhausted
+        | errno == eNOBUFS         = ResourceExhausted
+        | errno == eNODATA         = NoSuchThing
+        | errno == eNODEV          = UnsupportedOperation
+        | errno == eNOENT          = NoSuchThing
+        | errno == eNOEXEC         = InvalidArgument
+        | errno == eNOLCK          = ResourceExhausted
+        | errno == eNOLINK         = ResourceVanished
+        | errno == eNOMEM          = ResourceExhausted
+        | errno == eNOMSG          = NoSuchThing
+        | errno == eNONET          = NoSuchThing
+        | errno == eNOPROTOOPT     = UnsupportedOperation
+        | errno == eNOSPC          = ResourceExhausted
+        | errno == eNOSR           = ResourceExhausted
+        | errno == eNOSTR          = InvalidArgument
+        | errno == eNOSYS          = UnsupportedOperation
+        | errno == eNOTBLK         = InvalidArgument
+        | errno == eNOTCONN        = InvalidArgument
+        | errno == eNOTDIR         = InappropriateType
+        | errno == eNOTEMPTY       = UnsatisfiedConstraints
+        | errno == eNOTSOCK        = InvalidArgument
+        | errno == eNOTTY          = IllegalOperation
+        | errno == eNXIO           = NoSuchThing
+        | errno == eOPNOTSUPP      = UnsupportedOperation
+        | errno == ePERM           = PermissionDenied
+        | errno == ePFNOSUPPORT    = UnsupportedOperation
+        | errno == ePIPE           = ResourceVanished
+        | errno == ePROCLIM        = PermissionDenied
+        | errno == ePROCUNAVAIL    = UnsupportedOperation
+        | errno == ePROGMISMATCH   = ProtocolError
+        | errno == ePROGUNAVAIL    = UnsupportedOperation
+        | errno == ePROTO          = ProtocolError
+        | errno == ePROTONOSUPPORT = ProtocolError
+        | errno == ePROTOTYPE      = ProtocolError
+        | errno == eRANGE          = UnsupportedOperation
+        | errno == eREMCHG         = ResourceVanished
+        | errno == eREMOTE         = IllegalOperation
+        | errno == eROFS           = PermissionDenied
+        | errno == eRPCMISMATCH    = ProtocolError
+        | errno == eRREMOTE        = IllegalOperation
+        | errno == eSHUTDOWN       = IllegalOperation
+        | errno == eSOCKTNOSUPPORT = UnsupportedOperation
+        | errno == eSPIPE          = UnsupportedOperation
+        | errno == eSRCH           = NoSuchThing
+        | errno == eSRMNT          = UnsatisfiedConstraints
+        | errno == eSTALE          = ResourceVanished
+        | errno == eTIME           = TimeExpired
+        | errno == eTIMEDOUT       = TimeExpired
+        | errno == eTOOMANYREFS    = ResourceExhausted
+        | errno == eTXTBSY         = ResourceBusy
+        | errno == eUSERS          = ResourceExhausted
+        | errno == eWOULDBLOCK     = OtherError
+        | errno == eXDEV           = UnsupportedOperation
+        | otherwise                = OtherError
+#else
+-}
+    return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName))
+-- #endif
+
+foreign import ccall  "string.h strerror" strerror :: Errno -> IO (Ptr CChar)
+foreign import primitive "const.EINTR" eINTR :: Errno
+foreign import primitive "const.EWOULDBLOCK" eWOULDBLOCK :: Errno
+foreign import primitive "const.EAGAIN" eAGAIN :: Errno
+
addfile ./lib/Foreign/C/OldString.hs
hunk ./lib/Foreign/C/OldString.hs 1
+module Foreign.C.String where
+
+import Char
+import Foreign.C.Types
+import Foreign.Marshal.Array
+import Foreign.Ptr
+import Data.Word
+
+type CString = Ptr CChar
+type CStringLen = (Ptr CChar, Int)
+
+nUL :: CChar
+nUL = 0
+
+peekCString :: CString -> IO String
+peekCString cp = do
+    cs <- peekArray0 nUL cp
+    return (cCharsToChars cs)
+
+-- TODO UTF8
+-- cast [CChar] to [Char]
+--
+cCharsToChars :: [CChar] -> [Char]
+cCharsToChars xs  = map castCCharToChar xs
+
+-- cast [Char] to [CChar]
+--
+charsToCChars :: [Char] -> [CChar]
+charsToCChars xs  = map castCharToCChar xs
+
+castCCharToChar :: CChar -> Char
+castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))
+
+castCharToCChar :: Char -> CChar
+castCharToCChar ch = fromIntegral (ord ch)
+
addfile ./lib/Foreign/C/String.hs
hunk ./lib/Foreign/C/String.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Foreign.C.String
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Utilities for primitive marshalling of C strings.
+--
+-- The marshalling converts each Haskell character, representing a Unicode
+-- code point, to one or more bytes in a manner that, by default, is
+-- determined by the current locale.  As a consequence, no guarantees
+-- can be made about the relative length of a Haskell string and its
+-- corresponding C string, and therefore all the marshalling routines
+-- include memory allocation.  The translation between Unicode and the
+-- encoding of the current locale may be lossy.
+--
+-----------------------------------------------------------------------------
+
+module Foreign.C.String (   -- representation of strings in C
+
+  -- * C strings
+
+  CString,           -- = Ptr CChar
+  CStringLen,        -- = (Ptr CChar, Int)
+
+  -- ** Using a locale-dependent encoding
+
+  -- | Currently these functions are identical to their @CAString@ counterparts;
+  -- eventually they will use an encoding determined by the current locale.
+
+  -- conversion of C strings into Haskell strings
+  --
+  peekCString,       -- :: CString    -> IO String
+  peekCStringLen,    -- :: CStringLen -> IO String
+
+  -- conversion of Haskell strings into C strings
+  --
+  newCString,        -- :: String -> IO CString
+  newCStringLen,     -- :: String -> IO CStringLen
+
+  -- conversion of Haskell strings into C strings using temporary storage
+  --
+  withCString,       -- :: String -> (CString    -> IO a) -> IO a
+  withCStringLen,    -- :: String -> (CStringLen -> IO a) -> IO a
+
+  charIsRepresentable, -- :: Char -> IO Bool
+
+  -- ** Using 8-bit characters
+
+  -- | These variants of the above functions are for use with C libraries
+  -- that are ignorant of Unicode.  These functions should be used with
+  -- care, as a loss of information can occur.
+
+  castCharToCChar,   -- :: Char -> CChar
+  castCCharToChar,   -- :: CChar -> Char
+
+  peekCAString,      -- :: CString    -> IO String
+  peekCAStringLen,   -- :: CStringLen -> IO String
+  newCAString,       -- :: String -> IO CString
+  newCAStringLen,    -- :: String -> IO CStringLen
+  withCAString,      -- :: String -> (CString    -> IO a) -> IO a
+  withCAStringLen,   -- :: String -> (CStringLen -> IO a) -> IO a
+
+  -- * C wide strings
+
+  -- | These variants of the above functions are for use with C libraries
+  -- that encode Unicode using the C @wchar_t@ type in a system-dependent
+  -- way.  The only encodings supported are
+  --
+  -- * UTF-32 (the C compiler defines @__STDC_ISO_10646__@), or
+  --
+  -- * UTF-16 (as used on Windows systems).
+
+  CWString,          -- = Ptr CWchar
+  CWStringLen,       -- = (Ptr CWchar, Int)
+
+  peekCWString,      -- :: CWString    -> IO String
+  peekCWStringLen,   -- :: CWStringLen -> IO String
+  newCWString,       -- :: String -> IO CWString
+  newCWStringLen,    -- :: String -> IO CWStringLen
+  withCWString,      -- :: String -> (CWString    -> IO a) -> IO a
+  withCWStringLen,   -- :: String -> (CWStringLen -> IO a) -> IO a
+
+  ) where
+
+import Foreign.Marshal.Array
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Storable
+
+import Data.Word
+
+import Char ( chr, ord )
+
+-----------------------------------------------------------------------------
+-- Strings
+
+-- representation of strings in C
+-- ------------------------------
+
+-- | A C string is a reference to an array of C characters terminated by NUL.
+type CString    = Ptr CChar
+
+-- | A string with explicit length information in bytes instead of a
+-- terminating NUL (allowing NUL characters in the middle of the string).
+type CStringLen = (Ptr CChar, Int)
+
+-- exported functions
+-- ------------------
+--
+-- * the following routines apply the default conversion when converting the
+--   C-land character encoding into the Haskell-land character encoding
+
+-- | Marshal a NUL terminated C string into a Haskell string.
+--
+peekCString    :: CString -> IO String
+peekCString = peekCAString
+
+-- | Marshal a C string with explicit length into a Haskell string.
+--
+peekCStringLen           :: CStringLen -> IO String
+peekCStringLen = peekCAStringLen
+
+-- | Marshal a Haskell string into a NUL terminated C string.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * new storage is allocated for the C string and must be
+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
+--   'Foreign.Marshal.Alloc.finalizerFree'.
+--
+newCString :: String -> IO CString
+newCString = newCAString
+
+-- | Marshal a Haskell string into a C string (ie, character array) with
+-- explicit length information.
+--
+-- * new storage is allocated for the C string and must be
+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
+--   'Foreign.Marshal.Alloc.finalizerFree'.
+--
+newCStringLen     :: String -> IO CStringLen
+newCStringLen = newCAStringLen
+
+-- | Marshal a Haskell string into a NUL terminated C string using temporary
+-- storage.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withCString :: String -> (CString -> IO a) -> IO a
+withCString = withCAString
+
+-- | Marshal a Haskell string into a NUL terminated C string using temporary
+-- storage.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withCStringLen         :: String -> (CStringLen -> IO a) -> IO a
+withCStringLen = withCAStringLen
+
+-- | Determines whether a character can be accurately encoded in a 'CString'.
+-- Unrepresentable characters are converted to @\'?\'@.
+--
+-- Currently only Latin-1 characters are representable.
+charIsRepresentable :: Char -> IO Bool
+charIsRepresentable c = return (ord c < 256)
+
+-- single byte characters
+-- ----------------------
+--
+--   ** NOTE: These routines don't handle conversions! **
+
+-- | Convert a C byte, representing a Latin-1 character, to the corresponding
+-- Haskell character.
+castCCharToChar :: CChar -> Char
+castCCharToChar ch = chr (fromIntegral (fromIntegral ch :: Word8))
+
+-- | Convert a Haskell character to a C character.
+-- This function is only safe on the first 256 characters.
+castCharToCChar :: Char -> CChar
+castCharToCChar ch = fromIntegral (ord ch)
+
+-- | Marshal a NUL terminated C string into a Haskell string.
+--
+peekCAString    :: CString -> IO String
+--  #ifndef __GLASGOW_HASKELL__
+--peekCAString cp  = do
+--  cs <- peekArray0 nUL cp
+--  return (cCharsToChars cs)
+--  #else
+peekCAString cp = do
+  l <- lengthArray0 nUL cp
+  if l <= 0 then return "" else loop "" (l-1) where
+    loop s i = do
+        xval <- peekElemOff cp i
+	let val = castCCharToChar xval
+	val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)
+--  #endif
+
+-- | Marshal a C string with explicit length into a Haskell string.
+--
+peekCAStringLen           :: CStringLen -> IO String
+--  #ifndef __GLASGOW_HASKELL__
+-- peekCAStringLen (cp, len)  = do
+--   cs <- peekArray len cp
+--  return (cCharsToChars cs)
+--  #else
+peekCAStringLen (cp, len) 
+  | len <= 0  = return "" -- being (too?) nice.
+  | otherwise = loop [] (len-1)
+  where
+    loop acc i = do
+         xval <- peekElemOff cp i
+	 let val = castCCharToChar xval
+	   -- blow away the coercion ASAP.
+	 if (val `seq` (i == 0))
+	  then return (val:acc)
+	  else loop (val:acc) (i-1)
+--  #endif
+
+-- | Marshal a Haskell string into a NUL terminated C string.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * new storage is allocated for the C string and must be
+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
+--   'Foreign.Marshal.Alloc.finalizerFree'.
+--
+newCAString :: String -> IO CString
+--  #ifndef __GLASGOW_HASKELL__
+-- newCAString  = newArray0 nUL . charsToCChars
+--  #else
+newCAString str = do
+  ptr <- mallocArray0 (length str)
+  let
+	go [] n     = pokeElemOff ptr n nUL
+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+  go str 0
+  return ptr
+--  #endif
+
+-- | Marshal a Haskell string into a C string (ie, character array) with
+-- explicit length information.
+--
+-- * new storage is allocated for the C string and must be
+--   explicitly freed using 'Foreign.Marshal.Alloc.free' or
+--   'Foreign.Marshal.Alloc.finalizerFree'.
+--
+newCAStringLen     :: String -> IO CStringLen
+--  #ifndef __GLASGOW_HASKELL__
+-- newCAStringLen str  = do
+--   a <- newArray (charsToCChars str)
+--  return (pairLength str a)
+--  #else
+newCAStringLen str = do
+  ptr <- mallocArray0 len
+  let
+	go [] n     = n `seq` return ()	-- make it strict in n
+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+  go str 0
+  return (ptr, len) where
+    len = length str
+--  #endif
+
+-- | Marshal a Haskell string into a NUL terminated C string using temporary
+-- storage.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withCAString :: String -> (CString -> IO a) -> IO a
+--  #ifndef __GLASGOW_HASKELL__
+-- withCAString  = withArray0 nUL . charsToCChars
+--  #else
+withCAString str f =
+  allocaArray0 (length str) $ \ptr ->
+      let
+	go [] n     = pokeElemOff ptr n nUL
+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+      in do
+      go str 0
+      f ptr
+-- #endif
+
+-- | Marshal a Haskell string into a NUL terminated C string using temporary
+-- storage.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+-- withCAStringLen         :: String -> (CStringLen -> IO a) -> IO a
+--  #ifndef __GLASGOW_HASKELL__
+-- withCAStringLen str act  = withArray (charsToCChars str) $ act . pairLength str
+--  #else
+withCAStringLen str f =
+  allocaArray len $ \ptr ->
+      let
+	go [] n     = n `seq` return ()	-- make it strict in n
+    	go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+      in do
+      go str 0
+      f (ptr,len)
+  where
+    len = length str
+--  #endif
+
+-- auxiliary definitions
+-- ----------------------
+
+-- C's end of string character
+--
+nUL :: CChar
+nUL  = 0
+
+-- pair a C string with the length of the given Haskell string
+--
+pairLength :: String -> a -> (a, Int)
+pairLength  = flip (,) . length
+
+--  #ifndef __GLASGOW_HASKELL__
+-- cast [CChar] to [Char]
+--
+cCharsToChars :: [CChar] -> [Char]
+cCharsToChars xs  = map castCCharToChar xs
+
+-- cast [Char] to [CChar]
+--
+charsToCChars :: [Char] -> [CChar]
+charsToCChars xs  = map castCharToCChar xs
+--   #endif
+
+-----------------------------------------------------------------------------
+-- Wide strings
+
+-- representation of wide strings in C
+-- -----------------------------------
+
+-- | A C wide string is a reference to an array of C wide characters
+-- terminated by NUL.
+type CWString    = Ptr CWchar
+
+-- | A wide character string with explicit length information in bytes
+-- instead of a terminating NUL (allowing NUL characters in the middle
+-- of the string).
+type CWStringLen = (Ptr CWchar, Int)
+
+-- | Marshal a NUL terminated C wide string into a Haskell string.
+--
+peekCWString    :: CWString -> IO String
+peekCWString cp  = do
+  cs <- peekArray0 wNUL cp
+  return (cWcharsToChars cs)
+
+-- | Marshal a C wide string with explicit length into a Haskell string.
+--
+peekCWStringLen           :: CWStringLen -> IO String
+peekCWStringLen (cp, len)  = do
+  cs <- peekArray len cp
+  return (cWcharsToChars cs)
+
+-- | Marshal a Haskell string into a NUL terminated C wide string.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * new storage is allocated for the C wide string and must
+--   be explicitly freed using 'Foreign.Marshal.Alloc.free' or
+--   'Foreign.Marshal.Alloc.finalizerFree'.
+--
+newCWString :: String -> IO CWString
+newCWString  = newArray0 wNUL . charsToCWchars
+
+-- | Marshal a Haskell string into a C wide string (ie, wide character array)
+-- with explicit length information.
+--
+-- * new storage is allocated for the C wide string and must
+--   be explicitly freed using 'Foreign.Marshal.Alloc.free' or
+--   'Foreign.Marshal.Alloc.finalizerFree'.
+--
+newCWStringLen     :: String -> IO CWStringLen
+newCWStringLen str  = do
+  a <- newArray (charsToCWchars str)
+  return (pairLength str a)
+
+-- | Marshal a Haskell string into a NUL terminated C wide string using
+-- temporary storage.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withCWString :: String -> (CWString -> IO a) -> IO a
+withCWString  = withArray0 wNUL . charsToCWchars
+
+-- | Marshal a Haskell string into a NUL terminated C wide string using
+-- temporary storage.
+--
+-- * the Haskell string may /not/ contain any NUL characters
+--
+-- * the memory is freed when the subcomputation terminates (either
+--   normally or via an exception), so the pointer to the temporary
+--   storage must /not/ be used after this.
+--
+withCWStringLen         :: String -> (CWStringLen -> IO a) -> IO a
+withCWStringLen str act  = withArray (charsToCWchars str) $ act . pairLength str
+
+-- auxiliary definitions
+-- ----------------------
+
+wNUL :: CWchar
+wNUL = 0
+
+cWcharsToChars :: [CWchar] -> [Char]
+charsToCWchars :: [Char] -> [CWchar]
+
+
+cWcharsToChars xs  = map castCWcharToChar xs
+charsToCWchars xs  = map castCharToCWchar xs
+
+-- These conversions only make sense if __STDC_ISO_10646__ is defined
+-- (meaning that wchar_t is ISO 10646, aka Unicode)
+
+castCWcharToChar :: CWchar -> Char
+castCWcharToChar ch = chr (fromIntegral ch )
+
+castCharToCWchar :: Char -> CWchar
+castCharToCWchar ch = fromIntegral (ord ch)
+
addfile ./lib/Foreign/C/Types.hs
hunk ./lib/Foreign/C/Types.hs 1
+{-# OPTIONS --noprelude #-}
+module Foreign.C.Types where
+
+data CChar
+data CSChar
+data CUChar
+data CShort
+data CUShort
+data CInt
+data CUInt
+data CLong
+data CULong
+data CPtrdiff
+data CSize
+data CWchar
+data CSigAtomic
+data CLLong
+data CULLong
+data CClock
+data CTime
+data CFloat
+data CDouble
+data CLDouble
+data CFile
+data CJmpBuf
+data CFpos
+data CWint
addfile ./lib/Foreign/Marshal/Alloc.hs
hunk ./lib/Foreign/Marshal/Alloc.hs 1
+module Foreign.Marshal.Alloc (
+  -- * Memory allocation
+  -- ** Local allocation
+  alloca,       -- :: Storable a =>        (Ptr a -> IO b) -> IO b
+  allocaBytes,  -- ::               Int -> (Ptr a -> IO b) -> IO b
+
+  -- ** Dynamic allocation
+  malloc,       -- :: Storable a =>        IO (Ptr a)
+  mallocBytes,  -- ::               Int -> IO (Ptr a)
+
+  realloc,      -- :: Storable b => Ptr a        -> IO (Ptr b)
+  reallocBytes, -- ::		    Ptr a -> Int -> IO (Ptr a)
+
+  free,         -- :: Ptr a -> IO ()
+  finalizerFree -- :: FinalizerPtr a
+) where
+
+import Foreign.Ptr
+import Foreign.Storable
+import Prelude.IO
+import Foreign.C.Types
+import Foreign.Marshal.Utils
+import Monad
+import Prelude.IOError
+
+
+
+-- TODO handle exceptions
+allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
+allocaBytes b f = do
+    p <- mallocBytes b
+    r <- f p 
+    free p
+    return r
+
+
+-- exported functions
+-- ------------------
+
+-- |Allocate a block of memory that is sufficient to hold values of type
+-- @a@.  The size of the area allocated is determined by the 'sizeOf'
+-- method from the instance of 'Storable' for the appropriate type.
+--
+-- The memory may be deallocated using 'free' or 'finalizerFree' when
+-- no longer required.
+--
+malloc :: Storable a => IO (Ptr a)
+malloc  = doMalloc undefined
+doMalloc       :: Storable b => b -> IO (Ptr b)
+doMalloc dummy  = mallocBytes (sizeOf dummy)
+
+
+-- |@'alloca' f@ executes the computation @f@, passing as argument
+-- a pointer to a temporarily allocated block of memory sufficient to
+-- hold values of type @a@.
+--
+-- The memory is freed when @f@ terminates (either normally or via an
+-- exception), so the pointer passed to @f@ must /not/ be used after this.
+--
+alloca :: Storable a => (Ptr a -> IO b) -> IO b
+alloca  = doAlloca undefined
+doAlloca       :: Storable a' => a' -> (Ptr a' -> IO b') -> IO b'
+doAlloca dummy  = allocaBytes (sizeOf dummy)
+
+failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a)
+failWhenNULL name f = do
+   addr <- f
+   if addr == nullPtr
+      then ioError (userError (name++": out of memory"))
+      else return addr
+
+-- |Allocate a block of memory of the given number of bytes.
+-- The block of memory is sufficiently aligned for any of the basic
+-- foreign types that fits into a memory block of the allocated size.
+--
+-- The memory may be deallocated using 'free' or 'finalizerFree' when
+-- no longer required.
+--
+mallocBytes      :: Int -> IO (Ptr a)
+mallocBytes size  = failWhenNULL "malloc" (_malloc (fromIntegral size))
+
+
+-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
+-- to the size needed to store values of type @b@.  The returned pointer
+-- may refer to an entirely different memory area, but will be suitably
+-- aligned to hold values of type @b@.  The contents of the referenced
+-- memory area will be the same as of the original pointer up to the
+-- minimum of the original size and the size of values of type @b@.
+--
+-- If the argument to 'realloc' is 'nullPtr', 'realloc' behaves like
+-- 'malloc'.
+--
+realloc :: Storable b => Ptr a -> IO (Ptr b)
+realloc  = doRealloc undefined
+doRealloc           :: Storable b' => b' -> Ptr a' -> IO (Ptr b')
+doRealloc dummy ptr  = let
+                         size = fromIntegral (sizeOf dummy)
+                       in
+                       failWhenNULL "realloc" (_realloc ptr size)
+
+-- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes'
+-- to the given size.  The returned pointer may refer to an entirely
+-- different memory area, but will be sufficiently aligned for any of the
+-- basic foreign types that fits into a memory block of the given size.
+-- The contents of the referenced memory area will be the same as of
+-- the original pointer up to the minimum of the original size and the
+-- given size.
+--
+-- If the pointer argument to 'reallocBytes' is 'nullPtr', 'reallocBytes'
+-- behaves like 'malloc'.  If the requested size is 0, 'reallocBytes'
+-- behaves like 'free'.
+--
+reallocBytes          :: Ptr a -> Int -> IO (Ptr a)
+reallocBytes ptr 0     = do free ptr; return nullPtr
+reallocBytes ptr size  = 
+  failWhenNULL "realloc" (_realloc ptr (fromIntegral size))
+
+foreign import ccall "stdlib.h malloc" _malloc :: CSize -> IO (Ptr a) 
+foreign import ccall "stdlib.h free" free :: Ptr a -> IO ()
+foreign import ccall "stdlib.h realloc" _realloc :: Ptr a -> CSize -> IO (Ptr b)
addfile ./lib/Foreign/Marshal/Array.hs
hunk ./lib/Foreign/Marshal/Array.hs 1
+module Foreign.Marshal.Array (
+  -- * Marshalling arrays
+
+  -- ** Allocation
+  --
+  mallocArray,    -- :: Storable a => Int -> IO (Ptr a)
+  mallocArray0,   -- :: Storable a => Int -> IO (Ptr a)
+
+  allocaArray,    -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b
+  allocaArray0,   -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b
+
+  reallocArray,   -- :: Storable a => Ptr a -> Int -> IO (Ptr a)
+  reallocArray0,  -- :: Storable a => Ptr a -> Int -> IO (Ptr a)
+
+  -- ** Marshalling
+  --
+  peekArray,      -- :: Storable a =>         Int -> Ptr a -> IO [a]
+  peekArray0,     -- :: (Storable a, Eq a) => a   -> Ptr a -> IO [a]
+
+  pokeArray,      -- :: Storable a =>      Ptr a -> [a] -> IO ()
+  pokeArray0,     -- :: Storable a => a -> Ptr a -> [a] -> IO ()
+
+  -- ** Combined allocation and marshalling
+  --
+  newArray,       -- :: Storable a =>      [a] -> IO (Ptr a)
+  newArray0,      -- :: Storable a => a -> [a] -> IO (Ptr a)
+
+  withArray,      -- :: Storable a =>      [a] -> (Ptr a -> IO b) -> IO b
+  withArray0,     -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
+
+  withArrayLen,   -- :: Storable a =>      [a] -> (Int -> Ptr a -> IO b) -> IO b
+  withArrayLen0,  -- :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b
+
+  -- ** Copying
+
+  -- | (argument order: destination, source)
+  copyArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
+  moveArray,      -- :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
+
+  -- ** Finding the length
+  --
+  lengthArray0,   -- :: (Storable a, Eq a) => a -> Ptr a -> IO Int
+
+  -- ** Indexing
+  --
+  advancePtr,     -- :: Storable a => Ptr a -> Int -> Ptr a
+) where
+
+
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Prelude.IOError
+import Monad
+import Foreign.Marshal.Utils
+
+-- allocation
+-- ----------
+
+-- |Allocate storage for the given number of elements of a storable type
+-- (like 'Foreign.Marshal.Alloc.malloc', but for multiple elements).
+--
+mallocArray :: Storable a => Int -> IO (Ptr a)
+mallocArray  = doMalloc undefined
+doMalloc            :: Storable a' => a' -> Int -> IO (Ptr a')
+doMalloc dummy size  = mallocBytes (size * sizeOf dummy)
+
+-- |Like 'mallocArray', but add an extra position to hold a special
+-- termination element.
+--
+mallocArray0      :: Storable a => Int -> IO (Ptr a)
+mallocArray0 size  = mallocArray (size + 1)
+
+-- |Temporarily allocate space for the given number of elements
+-- (like 'Foreign.Marshal.Alloc.alloca', but for multiple elements).
+--
+allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b
+allocaArray  = doAlloca undefined
+doAlloca            :: Storable a' => a' -> Int -> (Ptr a' -> IO b') -> IO b'
+doAlloca dummy size  = allocaBytes (size * sizeOf dummy)
+
+-- |Like 'allocaArray', but add an extra position to hold a special
+-- termination element.
+--
+allocaArray0      :: Storable a => Int -> (Ptr a -> IO b) -> IO b
+allocaArray0 size  = allocaArray (size + 1)
+
+-- |Adjust the size of an array
+--
+reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a)
+reallocArray  = doRealloc undefined
+  where
+    doRealloc                :: Storable a' => a' -> Ptr a' -> Int -> IO (Ptr a')
+    doRealloc dummy ptr size  = reallocBytes ptr (size * sizeOf dummy)
+
+-- |Adjust the size of an array including an extra position for the end marker.
+--
+reallocArray0          :: Storable a => Ptr a -> Int -> IO (Ptr a)
+reallocArray0 ptr size  = reallocArray ptr (size + 1)
+
+
+-- |Convert an array of given length into a Haskell list.  This version
+-- traverses the array backwards using an accumulating parameter,
+-- which uses constant stack space.  The previous version using mapM
+-- needed linear stack space.
+--
+peekArray          :: Storable a => Int -> Ptr a -> IO [a]
+peekArray size ptr | size <= 0 = return []
+                 | otherwise = f (size-1) []
+  where
+    f 0 acc = do e <- peekElemOff ptr 0; return (e:acc)
+    f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc)
+  
+-- |Convert an array terminated by the given end marker into a Haskell list
+--
+peekArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO [a]
+peekArray0 marker ptr  = do
+  size <- lengthArray0 marker ptr
+  peekArray size ptr
+
+-- finding the length
+-- ------------------
+
+
+-- |Write the list elements consecutive into memory
+--
+pokeArray :: Storable a => Ptr a -> [a] -> IO ()
+pokeArray ptr vals =  zipWithM_ (pokeElemOff ptr) [0..] vals
+
+-- |Write the list elements consecutive into memory and terminate them with the
+-- given marker element
+--
+pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO ()
+pokeArray0 marker ptr vals  = do
+  pokeArray ptr vals
+  pokeElemOff ptr (length vals) marker
+
+-- combined allocation and marshalling
+-- -----------------------------------
+
+-- |Write a list of storable elements into a newly allocated, consecutive
+-- sequence of storable values
+-- (like 'Foreign.Marshal.Utils.new', but for multiple elements).
+--
+newArray      :: Storable a => [a] -> IO (Ptr a)
+newArray vals  = do
+  ptr <- mallocArray (length vals)
+  pokeArray ptr vals
+  return ptr
+
+-- |Write a list of storable elements into a newly allocated, consecutive
+-- sequence of storable values, where the end is fixed by the given end marker
+--
+newArray0             :: Storable a => a -> [a] -> IO (Ptr a)
+newArray0 marker vals  = do
+  ptr <- mallocArray0 (length vals)
+  pokeArray0 marker ptr vals
+  return ptr
+
+-- |Temporarily store a list of storable values in memory
+-- (like 'Foreign.Marshal.Utils.with', but for multiple elements).
+--
+withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b
+withArray vals = withArrayLen vals . const
+
+-- |Like 'withArray', but the action gets the number of values
+-- as an additional parameter
+--
+withArrayLen :: Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
+withArrayLen vals f  =
+  allocaArray len $ \ptr -> do
+      pokeArray ptr vals
+      res <- f len ptr
+      return res
+  where
+    len = length vals
+
+-- |Like 'withArray', but a terminator indicates where the array ends
+--
+withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b
+withArray0 marker vals = withArrayLen0 marker vals . const
+
+-- |Like 'withArrayLen', but a terminator indicates where the array ends
+--
+withArrayLen0 :: Storable a => a -> [a] -> (Int -> Ptr a -> IO b) -> IO b
+withArrayLen0 marker vals f  =
+  allocaArray0 len $ \ptr -> do
+      pokeArray0 marker ptr vals
+      res <- f len ptr
+      return res
+  where
+    len = length vals
+
+
+-- copying (argument order: destination, source)
+-- -------
+
+-- |Copy the given number of elements from the second array (source) into the
+-- first array (destination); the copied areas may /not/ overlap
+--
+copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
+copyArray  = doCopy undefined
+  where
+    doCopy                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()
+    doCopy dummy dest src size  = copyBytes dest src (size * sizeOf dummy)
+
+-- |Copy the given number of elements from the second array (source) into the
+-- first array (destination); the copied areas /may/ overlap
+--
+moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO ()
+moveArray  = doMove undefined
+  where
+    doMove                     :: Storable a' => a' -> Ptr a' -> Ptr a' -> Int -> IO ()
+    doMove dummy dest src size  = moveBytes dest src (size * sizeOf dummy)
+
+
+-- finding the length
+-- ------------------
+
+-- |Return the number of elements in an array, excluding the terminator
+--
+lengthArray0            :: (Storable a, Eq a) => a -> Ptr a -> IO Int
+lengthArray0 marker ptr  = loop 0
+  where
+    loop i = do
+        val <- peekElemOff ptr i
+        if val == marker then return i else loop (i+1)
+
+
+-- indexing
+-- --------
+
+-- |Advance a pointer into an array by the given number of elements
+--
+advancePtr :: Storable a => Ptr a -> Int -> Ptr a
+advancePtr  = doAdvance undefined
+  where
+    doAdvance             :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'
+    doAdvance dummy ptr i  = ptr `plusPtr` (i * sizeOf dummy)
addfile ./lib/Foreign/Marshal/Error.hs
hunk ./lib/Foreign/Marshal/Error.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Foreign.Marshal.Error
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Routines for testing return values and raising a 'userError' exception
+-- in case of values indicating an error state.
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Marshal.Error (
+  throwIf,       -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO a
+  throwIf_,      -- :: (a -> Bool) -> (a -> String) -> IO a       -> IO ()
+  throwIfNeg,    -- :: (Ord a, Num a) 
+	         -- =>                (a -> String) -> IO a       -> IO a
+  throwIfNeg_,   -- :: (Ord a, Num a)
+	         -- =>                (a -> String) -> IO a       -> IO ()
+  throwIfNull,   -- ::                String        -> IO (Ptr a) -> IO (Ptr a)
+
+  -- Discard return value
+  --
+  void           -- IO a -> IO ()
+) where
+
+import Foreign.Ptr
+import Prelude.IO
+import Prelude.IOError
+
+
+-- exported functions
+-- ------------------
+
+-- |Execute an 'IO' action, throwing a 'userError' if the predicate yields
+-- 'True' when applied to the result returned by the 'IO' action.
+-- If no exception is raised, return the result of the computation.
+--
+throwIf :: (a -> Bool)	-- ^ error condition on the result of the 'IO' action
+	-> (a -> String) -- ^ computes an error message from erroneous results
+			-- of the 'IO' action
+	-> IO a		-- ^ the 'IO' action to be executed
+	-> IO a
+throwIf pred msgfct act  = do
+    res <- act
+    (if pred res then ioError . userError . msgfct else return) res
+
+-- |Like 'throwIf', but discarding the result
+--
+throwIf_                 :: (a -> Bool) -> (a -> String) -> IO a -> IO ()
+throwIf_ pred msgfct act  = void $ throwIf pred msgfct act
+
+-- |Guards against negative result values
+--
+throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a
+throwIfNeg  = throwIf (< 0)
+
+-- |Like 'throwIfNeg', but discarding the result
+--
+throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO ()
+throwIfNeg_  = throwIf_ (< 0)
+
+-- |Guards against null pointers
+--
+throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a)
+throwIfNull  = throwIf (== nullPtr) . const
+
+-- |Discard the return value of an 'IO' action
+--
+void     :: IO a -> IO ()
+void act  = act >> return ()
addfile ./lib/Foreign/Marshal/Utils.hs
hunk ./lib/Foreign/Marshal/Utils.hs 1
+{-# OPTIONS -fno-implicit-prelude #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Foreign.Marshal.Utils
+-- Copyright   :  (c) The FFI task force 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  ffi@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Utilities for primitive marshaling
+--
+-----------------------------------------------------------------------------
+
+module Foreign.Marshal.Utils (
+  -- * General marshalling utilities
+
+  -- ** Combined allocation and marshalling
+  --
+  with,          -- :: Storable a => a -> (Ptr a -> IO b) -> IO b
+  new,           -- :: Storable a => a -> IO (Ptr a)
+
+  -- ** Marshalling of Boolean values (non-zero corresponds to 'True')
+  --
+  fromBool,      -- :: Num a => Bool -> a
+  toBool,	 -- :: Num a => a -> Bool
+
+  -- ** Marshalling of Maybe values
+  --
+  maybeNew,      -- :: (      a -> IO (Ptr a))
+		 -- -> (Maybe a -> IO (Ptr a))
+  maybeWith,     -- :: (      a -> (Ptr b -> IO c) -> IO c)
+		 -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)
+  maybePeek,     -- :: (Ptr a -> IO        b )
+		 -- -> (Ptr a -> IO (Maybe b))
+
+  -- ** Marshalling lists of storable objects
+  --
+  withMany,      -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res
+
+  -- ** Haskellish interface to memcpy and memmove
+  -- | (argument order: destination, source)
+  --
+  copyBytes,     -- :: Ptr a -> Ptr a -> Int -> IO ()
+  moveBytes     -- :: Ptr a -> Ptr a -> Int -> IO ()
+
+) where
+
+import Maybe
+import Foreign.Ptr	        ( Ptr, nullPtr )
+import Foreign.Storable		( Storable(poke) )
+import Foreign.C.Types    	( CSize )
+import Foreign.Marshal.Alloc 	( malloc, alloca )
+
+
+-- combined allocation and marshalling
+-- -----------------------------------
+
+-- |Allocate a block of memory and marshal a value into it
+-- (the combination of 'malloc' and 'poke').
+-- The size of the area allocated is determined by the 'Foreign.Storable.sizeOf'
+-- method from the instance of 'Storable' for the appropriate type.
+--
+-- The memory may be deallocated using 'Foreign.Marshal.Alloc.free' or
+-- 'Foreign.Marshal.Alloc.finalizerFree' when no longer required.
+--
+new     :: Storable a => a -> IO (Ptr a)
+new val  = 
+  do 
+    ptr <- malloc
+    poke ptr val
+    return ptr
+
+-- |@'with' val f@ executes the computation @f@, passing as argument
+-- a pointer to a temporarily allocated block of memory into which
+-- 'val' has been marshalled (the combination of 'alloca' and 'poke').
+--
+-- The memory is freed when @f@ terminates (either normally or via an
+-- exception), so the pointer passed to @f@ must /not/ be used after this.
+--
+with       :: Storable a => a -> (Ptr a -> IO b) -> IO b
+with val f  =
+  alloca $ \ptr -> do
+    poke ptr val
+    res <- f ptr
+    return res
+
+
+
+-- marshalling of Boolean values (non-zero corresponds to 'True')
+-- -----------------------------
+
+-- |Convert a Haskell 'Bool' to its numeric representation
+--
+fromBool       :: Num a => Bool -> a
+fromBool False  = 0
+fromBool True   = 1
+
+-- |Convert a Boolean in numeric representation to a Haskell value
+--
+toBool :: Num a => a -> Bool
+toBool  = (/= 0)
+
+
+-- marshalling of Maybe values
+-- ---------------------------
+
+-- |Allocate storage and marshall a storable value wrapped into a 'Maybe'
+--
+-- * the 'nullPtr' is used to represent 'Nothing'
+--
+maybeNew :: (      a -> IO (Ptr a))
+	 -> (Maybe a -> IO (Ptr a))
+maybeNew  = maybe (return nullPtr)
+
+-- |Converts a @withXXX@ combinator into one marshalling a value wrapped
+-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.
+--
+maybeWith :: (      a -> (Ptr b -> IO c) -> IO c) 
+	  -> (Maybe a -> (Ptr b -> IO c) -> IO c)
+maybeWith  = maybe ($ nullPtr)
+
+-- |Convert a peek combinator into a one returning 'Nothing' if applied to a
+-- 'nullPtr' 
+--
+maybePeek                           :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
+maybePeek peek ptr | ptr == nullPtr  = return Nothing
+		   | otherwise       = do a <- peek ptr; return (Just a)
+
+
+-- marshalling lists of storable objects
+-- -------------------------------------
+
+-- |Replicates a @withXXX@ combinator over a list of objects, yielding a list of
+-- marshalled objects
+--
+withMany :: (a -> (b -> res) -> res)  -- withXXX combinator for one object
+	 -> [a]			      -- storable objects
+	 -> ([b] -> res)	      -- action on list of marshalled obj.s
+	 -> res
+withMany _       []     f = f []
+withMany withFoo (x:xs) f = withFoo x $ \x' ->
+			      withMany withFoo xs (\xs' -> f (x':xs'))
+
+
+-- Haskellish interface to memcpy and memmove
+-- ------------------------------------------
+
+-- |Copies the given number of bytes from the second area (source) into the
+-- first (destination); the copied areas may /not/ overlap
+--
+copyBytes               :: Ptr a -> Ptr a -> Int -> IO ()
+copyBytes dest src size  = memcpy dest src (fromIntegral size)
+
+-- |Copies the given number of elements from the second area (source) into the
+-- first (destination); the copied areas /may/ overlap
+--
+moveBytes               :: Ptr a -> Ptr a -> Int -> IO ()
+moveBytes dest src size  = memmove dest src (fromIntegral size)
+
+
+-- auxilliary routines
+-- -------------------
+
+-- |Basic C routines needed for memory copying
+--
+foreign import ccall  "string.h memcpy" memcpy  :: Ptr a -> Ptr a -> CSize -> IO ()
+foreign import ccall  "string.h memmove" memmove :: Ptr a -> Ptr a -> CSize -> IO ()
addfile ./lib/Foreign/Ptr.hs
hunk ./lib/Foreign/Ptr.hs 1
+module Foreign.Ptr(
+    Ptr, 
+    nullPtr, 
+    castPtr, 
+    plusPtr, 
+    alignPtr, 
+    minusPtr, 
+    FunPtr, 
+    nullFunPtr, 
+    castFunPtr, 
+    castFunPtrToPtr, 
+    castPtrToFunPtr, 
+    freeHaskellFunPtr
+    ) where
+
+
+import Jhc.Addr
+import Foreign.Storable
+
+
+newtype Ptr a = Ptr Addr 
+newtype FunPtr a = FunPtr FunAddr 
+
+instance Storable (Ptr a) where 
+    sizeOf (Ptr a) = sizeOf a
+    alignment (Ptr a) = alignment a
+    peek p = peek (castPtr p) >>= return . Ptr 
+    poke p (Ptr x) = poke (castPtr p) x
+
+instance Eq (Ptr a) where
+    Ptr a == Ptr b = a == b
+    Ptr a /= Ptr b = a /= b
+
+instance Ord (Ptr a) where
+    compare (Ptr a) (Ptr b) = compare a b
+    Ptr a <= Ptr b = a <= b
+    Ptr a < Ptr b = a < b
+    Ptr a > Ptr b = a > b
+    Ptr a >= Ptr b = a >= b
+
+instance Show (Ptr a) where 
+    showsPrec n (Ptr x) = showsPrec n (toInteger (addrToWordPtr  x))
+
+nullPtr :: Ptr a
+nullPtr = Ptr nullAddr
+
+plusPtr :: Ptr a -> Int -> Ptr b
+plusPtr (Ptr addr) off = Ptr (plusAddr addr off)
+
+minusPtr :: Ptr a -> Int -> Ptr b
+minusPtr (Ptr addr) off = Ptr (plusAddr addr (negate off))
+
+castPtr :: Ptr a -> Ptr b
+castPtr (Ptr addr) = Ptr addr
+
+alignPtr :: Ptr a -> Int -> Ptr a
+alignPtr = error "alignPtr"
+--alignPtr addr@(Ptr a) (I# i)
+--  = case remAddr# a i of {
+--      0# -> addr;
+--      n -> Ptr (plusAddr# a (i -# n)) }    
+
+
+
+nullFunPtr = FunPtr nullFunAddr
+castFunPtr (FunPtr addr) = FunPtr addr
+
+--castFunPtrToPtr :: FunPtr a -> Ptr b
+--castFunPtrToPtr = unsafeCoerce
+
+--castPtrToFunPtr :: Ptr a -> FunPtr b
+--castPtrToFunPtr = unsafeCoerce
+
+
+foreign import primitive "integralCast" castFunPtrToPtr :: FunPtr a -> Ptr b
+foreign import primitive "integralCast" castPtrToFunPtr :: Ptr a -> FunPtr b
+
+
addfile ./lib/Foreign/Storable.hs
hunk ./lib/Foreign/Storable.hs 1
+module Foreign.Storable where
+
+import Foreign.Ptr
+
+class Storable a where
+    sizeOf :: a -> Int
+    alignment :: a -> Int
+    peekElemOff :: Ptr a -> Int -> IO a
+    pokeElemOff :: Ptr a -> Int -> a -> IO ()
+    peekByteOff :: Ptr b -> Int -> IO a
+    pokeByteOff :: Ptr b -> Int -> a -> IO ()
+    peek :: Ptr a -> IO a
+    poke :: Ptr a -> a -> IO ()
+
+    alignment x = sizeOf x
+    peekElemOff addr idx = do
+        peek (addr `plusPtr` (idx * sizeOf (_f addr)))
+    pokeElemOff addr idx x = poke (addr `plusPtr` (idx * sizeOf x)) x
+    peekByteOff addr off = peek (addr `plusPtr` off)
+    pokeByteOff addr off x = poke (addr `plusPtr` off) x
+
+_f :: Ptr a -> a
+_f _ = undefined
addfile ./lib/IO.hs
hunk ./lib/IO.hs 1
+module IO(
+    Handle,
+    IOMode(..),
+    BufferMode(..),
+    SeekMode(..),
+    hPutChar,
+    hPutStr,
+    hPutStrLn,
+    hPrint,
+    try,bracket,bracket_,hFlush,stdin,stdout,stderr,
+    hGetContents,
+    hClose,
+    openFile,
+    hIsOpen
+    
+    ) where 
+{-
+module IO(
+    Handle, 
+    IOMode(..),
+    BufferMode(..),
+    SeekMode(..),
+    stdin,
+    stdout,
+    stderr
+    )  where
+    -}
+
+
+import Jhc.IO
+import Jhc.Handle
+import Prelude.IOError
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.C.Types
+import Char(ord)
+
+
+data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+    deriving(Eq, Ord, Read, Show)
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+    deriving(Eq,Ord,Bounded,Enum,Read,Show)
+
+                      
+
+try            :: IO a -> IO (Either IOError a)
+try f          =  catch (do r <- f
+                            return (Right r))
+                        (return . Left)
+
+bracket        :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
+bracket before after m = do
+        x  <- before
+        rs <- try (m x)
+        after x
+        case rs of
+           Right r -> return r
+           Left  e -> ioError e
+
+-- variant of the above where middle computation doesn't want x
+bracket_        :: IO a -> (a -> IO b) -> IO c -> IO c
+bracket_ before after m = do
+         x  <- before
+         rs <- try m
+         after x
+         case rs of
+            Right r -> return r
+            Left  e -> ioError e
+
+
+
+
+
+
+hFlush :: Handle -> IO ()
+hFlush h = withHandle h c_fflush
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+
+hIsEOF :: Handle -> IO Bool
+hIsEOF h = withHandle h $ \ptr -> do
+    r <- c_feof ptr 
+    return (r /= 0) 
+
+hPutChar h ch = withHandle h $ \ptr -> do
+    c_fputwc (fromInt (ord ch)) ptr  
+    return ()
+
+hPutStr     :: Handle -> String -> IO ()
+hPutStr h s   = withHandle h $ \ptr -> do
+    sequence_ [ c_fputwc (fromInt (ord ch)) ptr | ch <- s ]
+	   
+hPutStrLn   :: Handle -> String -> IO ()
+hPutStrLn h s = do 
+    hPutStr h s
+    hPutChar h '\n'
+	   
+hPrint      :: Show a => Handle -> a -> IO ()
+hPrint h x    =  hPutStrLn h (show x)
+
+hGetContents :: Handle -> IO String
+hGetContents h = withHandle h $ \ptr -> do
+    let getContents' = do
+            ch <- c_fgetwc ptr 
+            case ch of
+                -1 -> return []
+                _ -> do
+                    xs <- unsafeInterleaveIO getContents'
+                    return (cwintToChar ch:xs)
+    unsafeInterleaveIO getContents'
+--hIsEOF :: Handle -> IO Bool
+
+foreign import primitive "integralCast" cwintToChar :: CWint -> Char
+
+foreign import ccall "stdio.h fflush" c_fflush :: Ptr Handle -> IO ()
+
+foreign import ccall "wchar.h getwc" c_fgetwc :: Ptr Handle -> IO CWint
+foreign import ccall "wchar.h putwc" c_fputwc :: CWchar -> Ptr Handle -> IO CWint
+
+foreign import ccall "stdio.h feof" c_feof :: Ptr Handle -> IO CInt
+
addfile ./lib/Ix.hs
hunk ./lib/Ix.hs 1
+module Ix ( Ix(range, index, inRange, rangeSize) ) where
+
+
+class  Ord a => Ix a  where
+    range     :: (a,a) -> [a]
+    index     :: (a,a) -> a -> Int
+    inRange   :: (a,a) -> a -> Bool
+    rangeSize :: (a,a) -> Int
+
+    rangeSize b@(l,h) | null (range b) = 0
+                      | otherwise      = index b h + 1 
+	-- NB: replacing "null (range b)" by  "not (l <= h)"
+	-- fails if the bounds are tuples.  For example,
+	-- 	(1,2) <= (2,1)
+	-- but the range is nevertheless empty
+	--	range ((1,2),(2,1)) = []
+
+instance  Ix Char  where
+    range (m,n)		= [m..n]
+    index b@(c,c') ci
+        | inRange b ci  =  fromEnum ci - fromEnum c
+        | otherwise     =  error "Ix.index: Index out of range."
+    inRange (c,c') i    =  c <= i && i <= c'
+
+instance  Ix Int  where
+    range (m,n)		= [m..n]
+    index b@(m,n) i
+        | inRange b i   =  i - m
+        | otherwise     =  error "Ix.index: Index out of range."
+    inRange (m,n) i     =  m <= i && i <= n
+
+instance  Ix Integer  where
+    range (m,n)		= [m..n]
+    index b@(m,n) i
+        | inRange b i   =  fromInteger (i - m)
+        | otherwise     =  error "Ix.index: Index out of range."
+    inRange (m,n) i     =  m <= i && i <= n
+
+-- instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples
+-- instance Ix Bool                  -- as derived
+-- instance Ix Ordering              -- as derived
+-- instance Ix ()                    -- as derived
addfile ./lib/Jhc.Addr.hs
hunk ./lib/Jhc.Addr.hs 1
+module Jhc.Addr where
+
+import Data.Word
+
+data Addr
+data FunAddr
+
+nullAddr = wordPtrToAddr 0
+nullFunAddr = wordPtrToFunAddr 0
+
+{-
+addrToWordPtr :: Addr -> WordPtr
+addrToWordPtr = integralCast
+wordPtrToAddr :: WordPtr -> Addr
+wordPtrToAddr = integralCast
+
+
+wordPtrToFunAddr :: WordPtr -> FunAddr 
+wordPtrToFunAddr = integralCast
+funAddrToWordPtr :: FunAddr -> WordPtr 
+funAddrToWordPtr = integralCast
+-}
+{-# INLINE plusAddr #-}
+plusAddr addr off = wordPtrToAddr $ addrToWordPtr addr + fromInt off 
+
+--foreign import primitive unsafeCoerce :: a -> b
+--foreign import primitive integralCast :: a -> b
+foreign import primitive "integralCast" addrToWordPtr :: Addr -> WordPtr
+foreign import primitive "integralCast" wordPtrToAddr :: WordPtr -> Addr
+foreign import primitive "integralCast" wordPtrToFunAddr :: WordPtr -> FunAddr 
+foreign import primitive "integralCast" funAddrToWordPtr :: FunAddr -> WordPtr 
addfile ./lib/Jhc.Array.hs
hunk ./lib/Jhc.Array.hs 1
+module Jhc.Array where
+
+
+data Array__ a
+
+
+
+-- | the number representing the size of the array must be less than or equal to the number of 
+-- elements in the list or bad stuff happens.
+foreign import primitive "unsafeNewArray__" :: Int -> [a] -> (Array__ a)
+
+
+foreign import primitive "unsafeAt__" :: Array__ a -> Int -> a 
+foreign import primitive "unsafeCopyArray__" :: Int -> [Either (Int,Int,Array__ a) a] -> Array__ a  
+
+
addfile ./lib/Jhc.Handle.hs
hunk ./lib/Jhc.Handle.hs 1
+module Jhc.Handle(
+    Handle(..), 
+    IOMode(..), 
+    stdin, 
+    stdout, 
+    stderr, 
+    withHandle, 
+    hClose,
+    hIsOpen,
+    openFile
+    ) where
+
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.C.Types
+import Jhc.IO
+import Foreign.C.String
+import Foreign.Marshal.Utils
+import Foreign.C.Error
+
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+    deriving(Eq, Ord, Bounded, Enum, Read, Show)
+
+data Handle = Handle { 
+    handleName :: String,
+    handleFile :: Ptr (Ptr Handle),
+    handleIOMode :: IOMode
+    }
+
+instance Show Handle where
+    showsPrec _ h s = handleName h ++ s
+
+stdin, stdout, stderr :: Handle
+
+make_builtin mode name std = Handle { handleName = "(" ++ name ++ ")", handleFile = std, handleIOMode = mode }
+
+stdin = make_builtin ReadMode "stdin" c_stdin
+stdout = make_builtin WriteMode "stdout" c_stdout
+stderr = make_builtin WriteMode "stderr" c_stderr
+
+{-
+stdin  = Handle (unsafePerformIO (peek c_stdin))
+stdout = Handle (unsafePerformIO (peek c_stdout))
+stderr = Handle (unsafePerformIO (peek c_stderr))
+-}
+
+foreign import ccall "stdio.h &stdin" c_stdin :: Ptr (Ptr Handle)
+foreign import ccall "stdio.h &stdout" c_stdout :: Ptr (Ptr Handle)
+foreign import ccall "stdio.h &stderr" c_stderr :: Ptr (Ptr Handle)
+
+withHandle h action = do
+    ptr <- peek (handleFile h) 
+    case ptr == nullPtr of 
+        True -> fail $ handleName h ++ ": handle  is closed"
+        False -> action ptr
+
+hClose h = do
+    ptr <- peek (handleFile h) 
+    case ptr == nullPtr of 
+        True -> return ()
+        False -> c_fclose ptr >> poke (handleFile h) nullPtr
+
+hIsOpen h = do
+    ptr <- peek (handleFile h) 
+    return (ptr /= nullPtr) 
+
+throwErrnoFN     :: String	-- ^ textual description of the error location
+               -> String
+	       -> IO a
+throwErrnoFN loc fn  = do
+    errno <- getErrno
+    ioError (errnoToIOError loc errno Nothing (Just fn))
+
+openFile :: FilePath -> IOMode -> IO Handle
+openFile fp m = do
+    ptr <- withCString fp $ \cfp -> c_fopen cfp (toStr m)
+    if ptr == nullPtr then throwErrnoFN "openFile" fp  else do
+        pptr <- new ptr
+        return Handle { handleName = fp, handleIOMode = m, handleFile = pptr }
+
+toStr ReadMode = read_str
+toStr WriteMode = write_str
+toStr AppendMode = append_str
+toStr ReadWriteMode = readwrite_str
+
+foreign import primitive "const.\"r\"" read_str :: Ptr CChar
+foreign import primitive "const.\"w\"" write_str  :: Ptr CChar
+foreign import primitive "const.\"a\"" append_str  :: Ptr CChar
+foreign import primitive "const.\"r+\"" readwrite_str  :: Ptr CChar
+    
+foreign import ccall "stdio.h fclose" c_fclose :: Ptr Handle -> IO CInt
+foreign import ccall "stdio.h fopen" c_fopen :: Ptr CChar -> Ptr CChar ->  IO (Ptr Handle)
+
+
addfile ./lib/Jhc.IO.hs
hunk ./lib/Jhc.IO.hs 1
+module Jhc.IO where
+
+import Prelude.IOError
+
+
+data World__ = World__
+    deriving(Show)
+
+data IOResult a = FailIO World__ IOError | JustIO World__ a
+newtype IO a = IO (World__ -> IOResult a)
+
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO (IO x) = case x World__ of 
+    FailIO _ z -> error $ case z of IOError z ->  z
+    JustIO _ a -> a
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO (IO action) = IO $ \w -> JustIO w $ case action w of
+    FailIO _ z -> error $ case z of IOError z ->  z
+    JustIO _ a -> a
+
+instance Monad IO where
+    return x = IO $ \w -> JustIO w x
+    IO x >>= f = IO $ \w -> case x w of 
+        JustIO w v -> case f v of
+            IO g -> g w 
+        FailIO w x -> FailIO w x
+    IO x >> IO y = IO $ \w -> case x w of
+        JustIO w _ -> y w
+        FailIO w x -> FailIO w x
+    fail s = ioError $ userError s
+
+instance Functor IO where
+    fmap f a = a >>= \x -> return (f x) 
+
+{-
+fixIO :: (a -> IO a) -> IO a
+fixIO k = IO $ \w -> let
+            r@(JustIO _ ans) = case k ans of 
+                    IO z -> case z w of
+                        FailIO _ z -> error $ case z of IOError z ->  z
+                        z -> z
+              in r
+-}
+
+fixIO :: (a -> IO a) -> IO a
+fixIO k = IO $ \w -> let
+            r = case k ans of 
+                    IO z -> z w
+            ans = case r of         
+                FailIO _ _ -> error $ "IOError"
+                JustIO _ z  -> z
+               in r   
+--foreign import primitive unsafeCoerce :: a -> b
+
+
+
+{-
+data World__ = World__
+
+data IO a = IO (World__ -> (World__,a))
+unIO (IO x) = x
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO (IO x) = case x World__ of (_,z) -> z
+--unsafePerformIO (IO x) = snd $ x undefined 
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO (IO m) = IO f where
+    f w = (w,case m w of (_,r) -> r) 
+-}
addfile ./lib/Jhc.Inspection.hs
hunk ./lib/Jhc.Inspection.hs 1
+module Jhc.Inspection where
+
+
+foreign import primitive indexToConstructor :: Int -> a
+foreign import primitive getConstructorIndex :: a -> Int
+foreign import primitive getConstructorName  :: a -> (String,String)
addfile ./lib/Jhc.Tuples.hs
hunk ./lib/Jhc.Tuples.hs 1
+
+-- | A place to collect the tuple instances.
+
+module Jhc.Tuples where
+
+
+
+{- TUPGEN! 
+
+instance (#Tup Eq #t) => Eq (#Tup #t) where
+    (#Tup #x) == (#Tup #y) = and [#List #x == #y] 
+    (#Tup #x) /= (#Tup #y) = or [#List #x /= #y] 
+
+-}
+
+
+
+instance (Ord a, Ord b) => Ord (a,b) where
+    compare (x,y) (a,b) = case compare x a of 
+        EQ -> compare y b
+        z -> z
+
+--instance (Eq a, Eq b) => Eq (a,b) where
+--    (x,y) == (a,b) = x == a && y == b
+
+
+
+
+instance  (Read a, Read b) => Read (a,b)  where
+    readsPrec p       = readParen False
+                            (\r -> [((x,y), w) | ("(",s) <- lex r,
+                                                 (x,t)   <- reads s,
+                                                 (",",u) <- lex t,
+                                                 (y,v)   <- reads u,
+                                                 (")",w) <- lex v ] )
+
+instance  (Show a, Show b) => Show (a,b)  where
+    showsPrec _ (x,y) s = (showChar '(' . shows x . showChar ',' .
+                                          shows y . showChar ')') 
+			  s
+
+instance (Show a, Show b, Show c) => Show (a, b, c) where
+    showsPrec _ (x,y,z) s = (showChar '(' . shows x . showChar ',' .
+					    shows y . showChar ',' .
+					    shows z . showChar ')')
+			    s
+
+instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
+    showsPrec _ (w,x,y,z) s = (showChar '(' . shows w . showChar ',' .
+					      shows x . showChar ',' .
+					      shows y . showChar ',' .
+					      shows z . showChar ')')
+			      s
+
+instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
+    showsPrec _ (v,w,x,y,z) s = (showChar '(' . shows v . showChar ',' .
+					     	shows w . showChar ',' .
+					     	shows x . showChar ',' .
+					     	shows y . showChar ',' .
+					     	shows z . showChar ')') 
+                                    s
+
+
+-- tupgen 2
+
+instance (Eq t1,Eq t2) => Eq (t1,t2) where
+    (x1,x2) == (y1,y2) = and [x1 == y1,x2 == y2] 
+    (x1,x2) /= (y1,y2) = or [x1 /= y1,x2 /= y2] 
+
+-- tupgen 3
+
+instance (Eq t1,Eq t2,Eq t3) => Eq (t1,t2,t3) where
+    (x1,x2,x3) == (y1,y2,y3) = and [x1 == y1,x2 == y2,x3 == y3] 
+    (x1,x2,x3) /= (y1,y2,y3) = or [x1 /= y1,x2 /= y2,x3 /= y3] 
+
+-- tupgen 4
+
+instance (Eq t1,Eq t2,Eq t3,Eq t4) => Eq (t1,t2,t3,t4) where
+    (x1,x2,x3,x4) == (y1,y2,y3,y4) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4] 
+    (x1,x2,x3,x4) /= (y1,y2,y3,y4) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4] 
+
+-- tupgen 5
+
+instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5) => Eq (t1,t2,t3,t4,t5) where
+    (x1,x2,x3,x4,x5) == (y1,y2,y3,y4,y5) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5] 
+    (x1,x2,x3,x4,x5) /= (y1,y2,y3,y4,y5) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5] 
+
+-- tupgen 6
+
+instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5,Eq t6) => Eq (t1,t2,t3,t4,t5,t6) where
+    (x1,x2,x3,x4,x5,x6) == (y1,y2,y3,y4,y5,y6) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5,x6 == y6] 
+    (x1,x2,x3,x4,x5,x6) /= (y1,y2,y3,y4,y5,y6) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5,x6 /= y6] 
+
+-- tupgen 7
+
+instance (Eq t1,Eq t2,Eq t3,Eq t4,Eq t5,Eq t6,Eq t7) => Eq (t1,t2,t3,t4,t5,t6,t7) where
+    (x1,x2,x3,x4,x5,x6,x7) == (y1,y2,y3,y4,y5,y6,y7) = and [x1 == y1,x2 == y2,x3 == y3,x4 == y4,x5 == y5,x6 == y6,x7 == y7] 
+    (x1,x2,x3,x4,x5,x6,x7) /= (y1,y2,y3,y4,y5,y6,y7) = or [x1 /= y1,x2 /= y2,x3 /= y3,x4 /= y4,x5 /= y5,x6 /= y6,x7 /= y7] 
+
addfile ./lib/List.hs
hunk ./lib/List.hs 1
+ 
+module List ( 
+    elemIndex, elemIndices,
+    find, findIndex, findIndices,
+    nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,
+    union, unionBy, intersect, intersectBy,
+    intersperse, transpose, partition, group, groupBy,
+    inits, tails, isPrefixOf, isSuffixOf,
+    mapAccumL, mapAccumR,
+    sort, sortBy, insert, insertBy, maximumBy, minimumBy,
+    genericLength, genericTake, genericDrop,
+    genericSplitAt, genericIndex, genericReplicate,
+    zip4, zip5, zip6, zip7,
+    zipWith4, zipWith5, zipWith6, zipWith7,
+    unzip4, unzip5, unzip6, unzip7, unfoldr,
+
+    -- ...and what the Prelude exports
+    -- []((:), []), -- This is built-in syntax
+    map, (++), concat, filter,
+    head, last, tail, init, null, length, (!!),
+    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+    iterate, repeat, replicate, cycle,
+    take, drop, splitAt, takeWhile, dropWhile, span, break,
+    lines, words, unlines, unwords, reverse, and, or,
+    any, all, elem, notElem, lookup,
+    sum, product, maximum, minimum, concatMap, 
+    zip, zip3, zipWith, zipWith3, unzip, unzip3
+    ) where
+
+
+infix 5 \\
+
+elemIndex               :: Eq a => a -> [a] -> Maybe Int
+elemIndex x             =  findIndex (x ==)
+        
+elemIndices             :: Eq a => a -> [a] -> [Int]
+elemIndices x           =  findIndices (x ==)
+                        
+find    :: (a -> Bool) -> [a] -> Maybe a
+find p xs =  case  filter p xs of
+    (x:_) -> Just x
+    [] -> Nothing
+
+findIndex               :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p  xs           = case findIndices p xs of
+    (x:_) -> Just x
+    [] -> Nothing
+
+findIndices             :: (a -> Bool) -> [a] -> [Int]
+findIndices p xs        =  [ i | (x,i) <- zip xs [0..], p x ]
+
+nub                     :: Eq a => [a] -> [a]
+nub                     =  nubBy (==)
+
+nubBy                   :: (a -> a -> Bool) -> [a] -> [a]
+nubBy eq []             =  []
+nubBy eq (x:xs)         =  x : nubBy eq (filter (\y -> not (eq x y)) xs)
+
+delete                  :: Eq a => a -> [a] -> [a]
+delete                  =  deleteBy (==)
+
+deleteBy                :: (a -> a -> Bool) -> a -> [a] -> [a]
+deleteBy eq x []        = []
+deleteBy eq x (y:ys)    = if x `eq` y then ys else y : deleteBy eq x ys
+
+(\\)                    :: Eq a => [a] -> [a] -> [a]
+(\\)                    =  foldl (flip delete)
+
+deleteFirstsBy          :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteFirstsBy eq       =  foldl (flip (deleteBy eq))
+
+union                   :: Eq a => [a] -> [a] -> [a]
+union                   =  unionBy (==)    
+
+unionBy                 :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+unionBy eq xs ys        =  xs ++ deleteFirstsBy eq (nubBy eq ys) xs
+
+intersect               :: Eq a => [a] -> [a] -> [a]
+intersect               =  intersectBy (==)
+
+intersectBy             :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+intersectBy eq xs ys    =  [x | x <- xs, any (eq x) ys]
+
+intersperse             :: a -> [a] -> [a]
+intersperse sep []      =  []
+intersperse sep [x]     =  [x]
+intersperse sep (x:xs)  =  x : sep : intersperse sep xs
+
+-- transpose is lazy in both rows and columns,
+--       and works for non-rectangular 'matrices'
+-- For example, transpose [[1,2],[3,4,5],[]]  =  [[1,3],[2,4],[5]]
+-- Note that [h | (h:t) <- xss] is not the same as (map head xss)
+--      because the former discards empty sublists inside xss
+transpose                :: [[a]] -> [[a]]
+transpose []             = []
+transpose ([]     : xss) = transpose xss
+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : 
+                           transpose (xs : [t | (h:t) <- xss])
+
+partition               :: (a -> Bool) -> [a] -> ([a],[a])
+partition p xs          =  (filter p xs, filter (not . p) xs)
+
+-- group splits its list argument into a list of lists of equal, adjacent
+-- elements.  e.g.,
+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
+group                   :: Eq a => [a] -> [[a]]
+group                   =  groupBy (==)
+
+groupBy                 :: (a -> a -> Bool) -> [a] -> [[a]]
+groupBy eq []           =  []
+groupBy eq (x:xs)       =  (x:ys) : groupBy eq zs
+                           where (ys,zs) = span (eq x) xs
+
+-- inits xs returns the list of initial segments of xs, shortest first.
+-- e.g., inits "abc" == ["","a","ab","abc"]
+inits                   :: [a] -> [[a]]
+inits []                =  [[]]
+inits (x:xs)            =  [[]] ++ map (x:) (inits xs)
+
+-- tails xs returns the list of all final segments of xs, longest first.
+-- e.g., tails "abc" == ["abc", "bc", "c",""]
+tails                   :: [a] -> [[a]]
+tails []                =  [[]]
+tails xxs@(_:xs)        =  xxs : tails xs
+
+isPrefixOf               :: Eq a => [a] -> [a] -> Bool
+isPrefixOf []     _      =  True
+isPrefixOf _      []     =  False
+isPrefixOf (x:xs) (y:ys) =  x == y && isPrefixOf xs ys
+
+isSuffixOf              :: Eq a => [a] -> [a] -> Bool
+isSuffixOf x y          =  reverse x `isPrefixOf` reverse y
+
+mapAccumL               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccumL f s []        =  (s, [])
+mapAccumL f s (x:xs)    =  (s'',y:ys)
+                           where (s', y ) = f s x
+                                 (s'',ys) = mapAccumL f s' xs
+
+mapAccumR               :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccumR f s []        =  (s, [])
+mapAccumR f s (x:xs)    =  (s'', y:ys)
+                           where (s'',y ) = f s' x
+                                 (s', ys) = mapAccumR f s xs
+
+unfoldr                 :: (b -> Maybe (a,b)) -> b -> [a]
+unfoldr f b             = case f b of
+                                Nothing    -> []
+                                Just (a,b) -> a : unfoldr f b
+
+sort                    :: (Ord a) => [a] -> [a]
+sort                    =  sortBy compare
+
+sortBy                  :: (a -> a -> Ordering) -> [a] -> [a]
+sortBy cmp              =  foldr (insertBy cmp) []
+
+insert                  :: (Ord a) => a -> [a] -> [a]
+insert                  = insertBy compare
+
+insertBy                :: (a -> a -> Ordering) -> a -> [a] -> [a]
+insertBy cmp x []       =  [x]
+insertBy cmp x ys@(y:ys')
+                        =  case cmp x y of
+                                GT -> y : insertBy cmp x ys'
+                                _  -> x : ys
+
+maximumBy               :: (a -> a -> Ordering) -> [a] -> a
+maximumBy cmp []        =  error "List.maximumBy: empty list"
+maximumBy cmp xs        =  foldl1 max xs
+                        where
+                           max x y = case cmp x y of
+                                        GT -> x
+                                        _  -> y
+
+minimumBy               :: (a -> a -> Ordering) -> [a] -> a
+minimumBy cmp []        =  error "List.minimumBy: empty list"
+minimumBy cmp xs        =  foldl1 min xs
+                        where
+                           min x y = case cmp x y of
+                                        GT -> y
+                                        _  -> x
+
+genericLength           :: (Integral a) => [b] -> a
+genericLength []        =  0
+genericLength (x:xs)    =  1 + genericLength xs
+
+genericTake             :: (Integral a) => a -> [b] -> [b]
+genericTake _ []        =  []
+genericTake 0 _         =  []
+genericTake n (x:xs) 
+   | n > 0              =  x : genericTake (n-1) xs
+   | otherwise          =  error "List.genericTake: negative argument"
+
+genericDrop             :: (Integral a) => a -> [b] -> [b]
+genericDrop 0 xs        =  xs
+genericDrop _ []        =  []
+genericDrop n (_:xs) 
+   | n > 0              =  genericDrop (n-1) xs
+   | otherwise          =  error "List.genericDrop: negative argument"
+
+genericSplitAt          :: (Integral a) => a -> [b] -> ([b],[b])
+genericSplitAt 0 xs     =  ([],xs)
+genericSplitAt _ []     =  ([],[])
+genericSplitAt n (x:xs) 
+   | n > 0              =  (x:xs',xs'')
+   | otherwise          =  error "List.genericSplitAt: negative argument"
+       where (xs',xs'') =  genericSplitAt (n-1) xs
+
+genericIndex            :: (Integral a) => [b] -> a -> b
+genericIndex (x:_)  0   =  x
+genericIndex (_:xs) n 
+        | n > 0         =  genericIndex xs (n-1)
+        | otherwise     =  error "List.genericIndex: negative argument"
+genericIndex _ _        =  error "List.genericIndex: index too large"
+
+genericReplicate        :: (Integral a) => a -> b -> [b]
+genericReplicate n x    =  genericTake n (repeat x)
+ 
+zip4                    :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
+zip4                    =  zipWith4 (,,,)
+
+zip5                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
+zip5                    =  zipWith5 (,,,,)
+
+zip6                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> 
+                              [(a,b,c,d,e,f)]
+zip6                    =  zipWith6 (,,,,,)
+
+zip7                    :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+                              [g] -> [(a,b,c,d,e,f,g)]
+zip7                    =  zipWith7 (,,,,,,)
+
+zipWith4                :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
+                        =  z a b c d : zipWith4 z as bs cs ds
+zipWith4 _ _ _ _ _      =  []
+
+zipWith5                :: (a->b->c->d->e->f) -> 
+                           [a]->[b]->[c]->[d]->[e]->[f]
+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
+                        =  z a b c d e : zipWith5 z as bs cs ds es
+zipWith5 _ _ _ _ _ _    =  []
+
+zipWith6                :: (a->b->c->d->e->f->g) ->
+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]
+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
+                        =  z a b c d e f : zipWith6 z as bs cs ds es fs
+zipWith6 _ _ _ _ _ _ _  =  []
+
+zipWith7                :: (a->b->c->d->e->f->g->h) ->
+                           [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
+                   =  z a b c d e f g : zipWith7 z as bs cs ds es fs gs
+zipWith7 _ _ _ _ _ _ _ _ = []
+
+{-
+unzip4                  :: [(a,b,c,d)] -> ([a],[b],[c],[d])
+unzip4                  =  foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
+                                        (a:as,b:bs,c:cs,d:ds))
+                                 ([],[],[],[])
+
+unzip5                  :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
+unzip5                  =  foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
+                                        (a:as,b:bs,c:cs,d:ds,e:es))
+                                 ([],[],[],[],[])
+
+unzip6                  :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
+unzip6                  =  foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
+                                        (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
+                                 ([],[],[],[],[],[])
+
+unzip7          :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
+unzip7          =  foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
+                                (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
+                         ([],[],[],[],[],[],[])
+-}
addfile ./lib/Locale.hs
hunk ./lib/Locale.hs 1
+module Locale where 
+
+data TimeLocale = TimeLocale {
+        wDays  :: [(String, String)],   -- full and abbreviated week days
+        months :: [(String, String)],   -- full and abbreviated months
+        amPm   :: (String, String),     -- AM/PM symbols
+        dateTimeFmt, dateFmt,           -- formatting strings
+          timeFmt, time12Fmt :: String     
+        } deriving (Eq, Ord, Show)
+
+defaultTimeLocale :: TimeLocale 
+defaultTimeLocale =  TimeLocale { 
+        wDays  = [("Sunday",   "Sun"),  ("Monday",    "Mon"),   
+                  ("Tuesday",  "Tue"),  ("Wednesday", "Wed"), 
+                  ("Thursday", "Thu"),  ("Friday",    "Fri"), 
+                  ("Saturday", "Sat")],
+
+        months = [("January",   "Jan"), ("February",  "Feb"),
+                  ("March",     "Mar"), ("April",     "Apr"),
+                  ("May",       "May"), ("June",      "Jun"),
+                  ("July",      "Jul"), ("August",    "Aug"),
+                  ("September", "Sep"), ("October",   "Oct"),
+                  ("November",  "Nov"), ("December",  "Dec")],
+
+        amPm = ("AM", "PM"),
+        dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y",
+        dateFmt = "%m/%d/%y",
+        timeFmt = "%H:%M:%S",
+        time12Fmt = "%I:%M:%S %p"
+        }
addfile ./lib/Maybe.hs
hunk ./lib/Maybe.hs 1
+ 
+module Maybe(
+    isJust, isNothing,
+    fromJust, fromMaybe, listToMaybe, maybeToList,
+    catMaybes, mapMaybe,
+
+    -- ...and what the Prelude exports
+    Maybe(Nothing, Just),
+    maybe
+  ) where
+
+import Prelude
+
+isJust                 :: Maybe a -> Bool
+isJust (Just a)        =  True
+isJust Nothing         =  False
+
+isNothing        :: Maybe a -> Bool
+isNothing        =  not . isJust
+
+fromJust               :: Maybe a -> a
+fromJust (Just a)      =  a
+fromJust Nothing       =  error "Maybe.fromJust: Nothing"
+
+fromMaybe              :: a -> Maybe a -> a
+fromMaybe d Nothing    =  d
+fromMaybe d (Just a)   =  a
+
+maybeToList            :: Maybe a -> [a]
+maybeToList Nothing    =  []
+maybeToList (Just a)   =  [a]
+
+listToMaybe            :: [a] -> Maybe a
+listToMaybe []         =  Nothing
+listToMaybe (a:_)      =  Just a
+ 
+catMaybes              :: [Maybe a] -> [a]
+catMaybes ms           =  [ m | Just m <- ms ]
+
+mapMaybe               :: (a -> Maybe b) -> [a] -> [b]
+mapMaybe f             =  catMaybes . map f
addfile ./lib/Monad.hs
hunk ./lib/Monad.hs 1
+module Monad(
+    MonadPlus(mzero, mplus),
+    join, guard, when, unless, ap, msum,
+    filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM, 
+    liftM, liftM2, liftM3, liftM4, liftM5,
+
+    -- ...and what the Prelude exports
+    Monad((>>=), (>>), return, fail),
+    Functor(fmap),
+    mapM, mapM_, sequence, sequence_, (=<<) 
+)where
+
+class Monad m => MonadPlus m where
+    mzero :: m a
+    mplus :: m a -> m a -> m a
+    mzero = fail "mzero"
+
+
+instance MonadPlus Maybe where
+    mzero = Nothing
+    Nothing `mplus` y = y
+    x `mplus` _ = x
+
+instance MonadPlus [] where
+    mzero = []
+    mplus = (++)
+
+
+-- Functions    
+
+
+msum  :: MonadPlus m => [m a] -> m a
+msum xs  =  foldr mplus mzero xs
+
+join             :: (Monad m) => m (m a) -> m a
+join x           =  x >>= id
+
+when             :: (Monad m) => Bool -> m () -> m ()
+when p s         =  if p then s else return ()
+
+unless           :: (Monad m) => Bool -> m () -> m ()
+unless p s       =  when (not p) s
+
+ap               :: (Monad m) => m (a -> b) -> m a -> m b
+ap               =  liftM2 ($)
+
+guard            :: MonadPlus m => Bool -> m ()
+guard p          =  if p then return () else mzero
+
+mapAndUnzipM     :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+mapAndUnzipM f xs = sequence (map f xs) >>= return . unzip
+
+zipWithM         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+zipWithM f xs ys =  sequence (zipWith f xs ys)
+
+zipWithM_         :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
+zipWithM_ f xs ys =  sequence_ (zipWith f xs ys)
+
+foldM            :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+foldM f a []     =  return a
+foldM f a (x:xs) =  f a x >>= \ y -> foldM f y xs
+
+filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
+filterM p []     = return []
+filterM p (x:xs) = do { b  <- p x;
+ys <- filterM p xs; 
+return (if b then (x:ys) else ys)
+   }
+
+liftM            :: (Monad m) => (a -> b) -> (m a -> m b)
+liftM f          =  \a -> do { a' <- a; return (f a') }
+
+liftM2           :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
+liftM2 f         =  \a b -> do { a' <- a; b' <- b; return (f a' b') }
+
+liftM3           :: (Monad m) => (a -> b -> c -> d) ->
+                                 (m a -> m b -> m c -> m d)
+liftM3 f         =  \a b c -> do { a' <- a; b' <- b; c' <- c;
+   return (f a' b' c') }
+
+liftM4           :: (Monad m) => (a -> b -> c -> d -> e) ->
+                                 (m a -> m b -> m c -> m d -> m e)
+liftM4 f         =  \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;
+     return (f a' b' c' d') }
+
+liftM5           :: (Monad m) => (a -> b -> c -> d -> e -> f) ->
+                                 (m a -> m b -> m c -> m d -> m e -> m f)
+liftM5 f         =  \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;
+       e' <- e; return (f a' b' c' d' e') }
+
addfile ./lib/Numeric.hs
hunk ./lib/Numeric.hs 1
+module Numeric(fromRat,
+               showSigned, showIntAtBase,
+               showInt, showOct, showHex,
+               readSigned, readInt,
+               readDec, readOct, readHex, 
+               floatToDigits,
+               showEFloat, showFFloat, showGFloat, showFloat, 
+               readFloat, lexDigits) where
+
+import Char   ( isDigit, isOctDigit, isHexDigit
+              , digitToInt, intToDigit )
+--import Ratio  ( (%), numerator, denominator )
+--import Array  ( (!), Array, array )
+import Prelude.Text
+
+-- This converts a rational to a floating.  This should be used in the
+-- Fractional instances of Float and Double.
+
+{-
+fromRat :: (RealFloat a) => Rational -> a
+fromRat x = 
+    if x == 0 then encodeFloat 0 0              -- Handle exceptional cases
+    else if x < 0 then - fromRat' (-x)          -- first.
+    else fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+  where b = floatRadix r
+        p = floatDigits r
+        (minExp0, _) = floatRange r
+        minExp = minExp0 - p            -- the real minimum exponent
+        xMin = toRational (expt b (p-1))
+        xMax = toRational (expt b p)
+        p0 = (integerLogBase b (numerator x) -
+              integerLogBase b (denominator x) - p) `max` minExp
+        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+        r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational -> 
+             Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x =
+    if p <= minExp then
+        (x, p)
+    else if x >= xMax then
+        scaleRat b minExp xMin xMax (p+1) (x/b)
+    else if x < xMin  then
+        scaleRat b minExp xMin xMax (p-1) (x*b)
+    else
+        (x, p)
+-}
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: Integer -> Int -> Integer
+expt base n = base^n
+{-
+expt base n =
+    if base == 2 && n >= minExpt && n <= maxExpt then
+        expts!n
+    else
+        base^n
+
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+-}
+
+-- Compute the (floor of the) log of i in base b.
+-- Simplest way would be just divide i by b until it's smaller then b,
+-- but that would be very slow!  We are just slightly more clever.
+integerLogBase :: Integer -> Integer -> Int
+integerLogBase b i =
+     if i < b then
+        0
+     else
+        -- Try squaring the base first to cut down the number of divisions.
+        let l = 2 * integerLogBase (b*b) i
+            doDiv :: Integer -> Int -> Int
+            doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
+        in  doDiv (i `div` (b^l)) l
+
+
+-- Misc utilities to show integers and floats 
+
+showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x 
+  | x < 0     = showParen (p > 6) (showChar '-' . showPos (-x))
+  | otherwise = showPos x
+
+-- showInt, showOct, showHex are used for positive numbers only
+showInt, showOct, showHex :: Integral a => a -> ShowS
+showOct = showIntAtBase  8 intToDigit
+showInt = showIntAtBase 10 intToDigit
+showHex = showIntAtBase 16 intToDigit
+
+showIntAtBase :: Integral a 
+	      => a              -- base
+	      -> (Int -> Char)  -- digit to char
+	      -> a              -- number to show
+	      -> ShowS
+showIntAtBase base intToDig n rest
+  | n < 0     = error $ "Numeric.showIntAtBase: can't show negative numbers " ++ show n
+  | n' == 0   = rest'
+  | otherwise = showIntAtBase base intToDig n' rest'
+  where
+    (n',d) = quotRem n base
+    rest'  = intToDig (fromIntegral d) : rest
+
+
+readSigned :: (Real a) => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+                     where read' r  = read'' r ++
+                                      [(-x,t) | ("-",s) <- lex r,
+                                                (x,t)   <- read'' s]
+                           read'' r = [(n,s)  | (str,s) <- lex r,
+                                                (n,"")  <- readPos str]
+
+
+-- readInt reads a string of digits using an arbitrary base.  
+-- Leading minus signs must be handled elsewhere.
+
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+   [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+          | (ds,r) <- nonnull isDig s ]
+
+-- Unsigned readers for various bases
+readDec, readOct, readHex :: (Integral a) => ReadS a
+readDec = readInt 10 isDigit    digitToInt
+readOct = readInt  8 isOctDigit digitToInt
+readHex = readInt 16 isHexDigit digitToInt
+
+
+showEFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
+showGFloat     :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFloat      :: (RealFloat a) => a -> ShowS
+
+showEFloat d x =  showString (formatRealFloat FFExponent d x)
+showFFloat d x =  showString (formatRealFloat FFFixed d x)
+showGFloat d x =  showString (formatRealFloat FFGeneric d x)
+showFloat      =  showGFloat Nothing 
+
+-- These are the format types.  This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x 
+  = s
+  where 
+    base = 10
+    s = if isNaN x then 
+            "NaN"
+        else if isInfinite x then 
+            if x < 0 then "-Infinity" else "Infinity"
+        else if x < 0 || isNegativeZero x then 
+            '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
+        else 
+            doFmt fmt (floatToDigits (toInteger base) x)
+    
+    doFmt fmt (is, e)
+      = let 
+           ds = map intToDigit is
+        in  
+        case fmt of
+          FFGeneric -> 
+              doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+                    (is, e)
+          FFExponent ->
+            case decs of
+              Nothing ->
+                case ds of
+                   []    -> "0.0e0"
+                   [d]   -> d : ".0e" ++ show (e-1)
+                   d:ds  -> d : '.' : ds ++ 'e':show (e-1)
+          
+              Just dec ->
+                let dec' = max dec 1 in
+                case is of
+                  [] -> '0':'.':take dec' (repeat '0') ++ "e0"
+                  _ ->
+                    let (ei, is') = roundTo base (dec'+1) is
+                        d:ds = map intToDigit
+                                   (if ei > 0 then init is' else is')
+                    in d:'.':ds  ++ "e" ++ show (e-1+ei)
+          
+          FFFixed ->
+            case decs of
+               Nothing 	-- Always prints a decimal point
+                 | e > 0     -> take e (ds ++ repeat '0')
+                                ++ '.' : mk0 (drop e ds)
+                 | otherwise -> "0." ++ mk0 (replicate (-e) '0' ++ ds)
+              
+               Just dec ->  -- Print decimal point iff dec > 0
+                 let dec' = max dec 0 in
+                 if e >= 0 then
+                   let (ei, is') = roundTo base (dec' + e) is
+                       (ls, rs)  = splitAt (e+ei) 
+                                              (map intToDigit is')
+                   in  mk0 ls ++ mkdot0 rs
+                 else
+                   let (ei, is') = roundTo base dec' 
+                                           (replicate (-e) 0 ++ is)
+                       d : ds = map intToDigit 
+                                    (if ei > 0 then is' else 0:is')
+                   in  d : mkdot0 ds
+            where   
+              mk0 "" = "0"        -- Print 0.34, not .34
+              mk0 s  = s  
+    
+              mkdot0 "" = ""       -- Print 34, not 34.
+              mkdot0 s  = '.' : s  -- when the format specifies no
+			           -- digits after the decimal point
+    
+
+roundTo :: Int -> Int -> [Int] -> (Int, [Int])
+roundTo base d is = case f d is of
+                (0, is) -> (0, is)
+                (1, is) -> (1, 1 : is)
+  where b2 = base `div` 2
+        f n [] = (0, replicate n 0)
+        f 0 (i:_) = (if i >= b2 then 1 else 0, [])
+        f d (i:is) = 
+            let (c, ds) = f (d-1) is
+                i' = c + i
+            in  if i' == base then (1, 0:ds) else (0, i':ds)
+
+--
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
+-- The version here uses a much slower logarithm estimator.  
+-- It should be improved.
+
+-- This function returns a non-empty list of digits (Ints in [0..base-1])
+-- and an exponent.  In general, if
+--      floatToDigits r = ([a, b, ... z], e)
+-- then
+--      r = 0.ab..z * base^e
+-- 
+
+floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+
+floatToDigits _ 0 = ([], 0)
+floatToDigits base x =
+    let (f0, e0) = decodeFloat x
+        (minExp0, _) = floatRange x
+        p = floatDigits x
+        b = floatRadix x
+        minExp = minExp0 - p            -- the real minimum exponent
+
+        -- Haskell requires that f be adjusted so denormalized numbers
+        -- will have an impossibly low exponent.  Adjust for this.
+        f :: Integer
+        e :: Int
+        (f, e) = let n = minExp - e0
+                 in  if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+        (r, s, mUp, mDn) =
+           if e >= 0 then
+               let be = b^e in
+               if f == b^(p-1) then
+                   (f*be*b*2, 2*b, be*b, b)
+               else
+                   (f*be*2, 2, be, be)
+           else
+               if e > minExp && f == b^(p-1) then
+                   (f*b*2, b^(-e+1)*2, b, 1)
+               else
+                   (f*2, b^(-e)*2, 1, 1)
+        k = 
+            let k0 =
+                    if b==2 && base==10 then
+                        -- logBase 10 2 is slightly bigger than 3/10 so
+                        -- the following will err on the low side.  Ignoring
+                        -- the fraction will make it err even more.
+                        -- Haskell promises that p-1 <= logBase b f < p.
+                        (p - 1 + e0) * 3 `div` 10
+                    else
+                        ceiling ((log ((fromInteger (f+1))::Double) + 
+                                 fromIntegral e * log (fromInteger b)) / 
+                                  log (fromInteger base))
+                fixup n =
+                    if n >= 0 then
+                        if r + mUp <= expt base n * s then n else fixup (n+1)
+                    else
+                        if expt base (-n) * (r + mUp) <= s then n
+                                                           else fixup (n+1)
+            in  fixup (k0::Int)
+
+        gen ds rn sN mUpN mDnN =
+            let (dn, rn') = (rn * base) `divMod` sN
+                mUpN' = mUpN * base
+                mDnN' = mDnN * base
+            in  case (rn' < mDnN', rn' + mUpN' > sN) of
+                (True,  False) -> dn : ds
+                (False, True)  -> dn+1 : ds
+                (True,  True)  -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+                (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+        rds =
+            if k >= 0 then
+                gen [] r (s * expt base k) mUp mDn
+            else
+                let bk = expt base (-k)
+                in  gen [] (r * bk) s (mUp * bk) (mDn * bk)
+    in  (map fromIntegral (reverse rds), k)
+
+
+
+-- This floating point reader uses a less restrictive syntax for floating
+-- point than the Haskell lexer.  The `.' is optional.
+
+readFloat     :: (RealFrac a) => ReadS a
+readFloat r = error "readFloat"
+{-
+readFloat r    = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
+                                                       (k,t)   <- readExp s] ++
+                 [ (0/0, t) | ("NaN",t)      <- lex r] ++
+                 [ (1/0, t) | ("Infinity",t) <- lex r]
+               where 
+                 readFix r = [(read (ds++ds'), length ds', t)
+                             | (ds,d) <- lexDigits r,
+                               (ds',t) <- lexFrac d ]
+               
+                 lexFrac ('.':ds) = lexDigits ds
+                 lexFrac s        = [("",s)]        
+                 
+                 readExp (e:s) | e `elem` "eE" = readExp' s
+                 readExp s                     = [(0,s)]
+                 
+                 readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+                 readExp' ('+':s) = readDec s
+                 readExp' s       = readDec s
+-}
+lexDigits        :: ReadS String 
+lexDigits        =  nonnull isDigit
+
+nonnull          :: (Char -> Bool) -> ReadS String
+nonnull p s      =  [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
addfile ./lib/Prelude.Float.hs
hunk ./lib/Prelude.Float.hs 1
+module Prelude.Float() where 
+
+import Ratio
+import Foreign.C.Types
+import Foreign.Ptr
+import Foreign.Marshal.Alloc
+import Jhc.IO
+import Foreign.Storable
+
+
+{-  template
+
+
+instance Fractional @type@ where
+    (/) = divide@type@  
+    fromRational x = numerator x / denominator x
+
+instance Floating @type@ where
+    pi = atan 1 * 4
+    sqrt = c_sqrt@x@
+    exp = c_exp@x@
+    log = c_log@x@
+    sin = c_sin@x@
+    cos = c_cos@x@
+    tan = c_tan@x@
+    asin = c_asin@x@
+    acos = c_acos@x@
+    atan = c_atan@x@
+    (**) = exponent@type@
+    asinh = c_asinh@x@
+    acosh = c_acosh@x@
+    atanh = c_atanh@x@
+    sinh = c_sinh@x@
+    cosh = c_cosh@x@
+    tanh = c_tanh@x@
+    
+
+foreign import ccall "-lm math.h sqrt@x@" c_sqrt@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h exp@x@" c_exp@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h log@x@" c_log@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h sin@x@" c_sin@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h cos@x@" c_cos@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h tan@x@" c_tan@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h asin@x@" c_asin@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h acos@x@" c_acos@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h atan@x@" c_atan@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h asinh@x@" c_asinh@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h acosh@x@" c_acosh@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h atanh@x@" c_atanh@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h sinh@x@" c_sinh@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h cosh@x@" c_cosh@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h tanh@x@" c_tanh@x@ :: @type@ -> @type@
+foreign import ccall "-lm math.h pow@x@" exponent@type@ ::  @type@ -> @type@ -> @type@
+
+foreign import primitive "divide" divide@type@ ::  @type@ -> @type@ -> @type@
+
+-}
+
+
+
+
+instance Fractional Float where
+    a / b = divideFloat a b 
+    fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
+
+instance Floating Float where
+    pi = c_pif
+    sqrt = c_sqrtf
+    exp = c_expf
+    log = c_logf
+    sin = c_sinf
+    cos = c_cosf
+    tan = c_tanf
+    asin = c_asinf
+    acos = c_acosf
+    atan = c_atanf
+    (**) = exponentFloat
+    asinh = c_asinhf
+    acosh = c_acoshf
+    atanh = c_atanhf
+    sinh = c_sinhf
+    cosh = c_coshf
+    tanh = c_tanhf
+    
+
+foreign import ccall "-lm math.h sqrtf" c_sqrtf :: Float -> Float
+foreign import ccall "-lm math.h expf" c_expf :: Float -> Float
+foreign import ccall "-lm math.h logf" c_logf :: Float -> Float
+foreign import ccall "-lm math.h sinf" c_sinf :: Float -> Float
+foreign import ccall "-lm math.h cosf" c_cosf :: Float -> Float
+foreign import ccall "-lm math.h tanf" c_tanf :: Float -> Float
+foreign import ccall "-lm math.h asinf" c_asinf :: Float -> Float
+foreign import ccall "-lm math.h acosf" c_acosf :: Float -> Float
+foreign import ccall "-lm math.h atanf" c_atanf :: Float -> Float
+foreign import ccall "-lm math.h asinhf" c_asinhf :: Float -> Float
+foreign import ccall "-lm math.h acoshf" c_acoshf :: Float -> Float
+foreign import ccall "-lm math.h atanhf" c_atanhf :: Float -> Float
+foreign import ccall "-lm math.h sinhf" c_sinhf :: Float -> Float
+foreign import ccall "-lm math.h coshf" c_coshf :: Float -> Float
+foreign import ccall "-lm math.h tanhf" c_tanhf :: Float -> Float
+foreign import ccall "-lm math.h powf" exponentFloat ::  Float -> Float -> Float
+
+foreign import primitive "divide" divideFloat ::  Float -> Float -> Float
+
+
+
+
+
+instance Fractional Double where
+    (/) = divideDouble  
+    fromRational x = fromInteger (numerator x) / fromInteger (denominator x)
+
+instance Floating Double where
+    pi = c_pi
+    sqrt = c_sqrt
+    exp = c_exp
+    log = c_log
+    sin = c_sin
+    cos = c_cos
+    tan = c_tan
+    asin = c_asin
+    acos = c_acos
+    atan = c_atan
+    (**) = exponentDouble
+    asinh = c_asinh
+    acosh = c_acosh
+    atanh = c_atanh
+    sinh = c_sinh
+    cosh = c_cosh
+    tanh = c_tanh
+    
+
+foreign import ccall "-lm math.h sqrt" c_sqrt :: Double -> Double
+foreign import ccall "-lm math.h exp" c_exp :: Double -> Double
+foreign import ccall "-lm math.h log" c_log :: Double -> Double
+foreign import ccall "-lm math.h sin" c_sin :: Double -> Double
+foreign import ccall "-lm math.h cos" c_cos :: Double -> Double
+foreign import ccall "-lm math.h tan" c_tan :: Double -> Double
+foreign import ccall "-lm math.h asin" c_asin :: Double -> Double
+foreign import ccall "-lm math.h acos" c_acos :: Double -> Double
+foreign import ccall "-lm math.h atan" c_atan :: Double -> Double
+foreign import ccall "-lm math.h asinh" c_asinh :: Double -> Double
+foreign import ccall "-lm math.h acosh" c_acosh :: Double -> Double
+foreign import ccall "-lm math.h atanh" c_atanh :: Double -> Double
+foreign import ccall "-lm math.h sinh" c_sinh :: Double -> Double
+foreign import ccall "-lm math.h cosh" c_cosh :: Double -> Double
+foreign import ccall "-lm math.h tanh" c_tanh :: Double -> Double
+foreign import ccall "-lm math.h pow" exponentDouble ::  Double -> Double -> Double
+
+foreign import primitive "divide" divideDouble ::  Double -> Double -> Double
+
+
+instance Real Float where 
+    toRational x	=  (m%1)*(b%1)^^n
+			   where (m,n) = decodeFloat x
+				 b     = floatRadix  x
+instance Real Double where 
+    toRational x	=  (m%1)*(b%1)^^n
+			   where (m,n) = decodeFloat x
+				 b     = floatRadix  x
+
+
+instance RealFrac Float where
+    properFraction x
+      = case (decodeFloat x)      of { (m,n) ->
+    	let  b = floatRadix x     in
+    	if n >= 0 then
+	    (fromInteger m * fromInteger b ^ n, 0.0)
+    	else
+	    case (quotRem m (b^(negate n))) of { (w,r) ->
+	    (fromInteger w, encodeFloat r n)
+	    }
+        }              
+
+instance RealFrac Double where
+    properFraction x
+      = case (decodeFloat x)      of { (m,n) ->
+    	let  b = floatRadix x     in
+    	if n >= 0 then
+	    (fromInteger m * fromInteger b ^ n, 0.0)
+    	else
+	    case (quotRem m (b^(negate n))) of { (w,r) ->
+	    (fromInteger w, encodeFloat r n)
+	    }
+        }              
+
+instance RealFloat Float where 
+    floatRadix _ = c_flt_radix
+    floatDigits _ = c_flt_mant_dig
+    floatRange _ = (c_flt_min_exp,c_flt_max_exp)
+
+    exponent x		= case decodeFloat x of
+			    (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+    significand x	= case decodeFloat x of
+			    (m,_) -> encodeFloat m (negate (floatDigits x))
+
+    scaleFloat k x	= case decodeFloat x of
+			    (m,n) -> encodeFloat m (n+k)        
+    isNaN x = c_isnanf x /= 0
+    isInfinite x = c_isinfinitef x /= 0
+    isDenormalized _ = False
+    isNegativeZero x = x == 0 && c_signbitf x /= 0 
+    isIEEE _ = True
+    encodeFloat i e = double2float $ c_ldexp (integer2double i) (fromInt e) 
+    decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do
+        x' <- c_frexp (float2double x) ptr
+        exp <- peek ptr
+        let x'' =  c_ldexp x' (fromInt $ floatDigits x)
+        return (double2integer x'', fromIntegral exp  - floatDigits x)
+
+    
+    
+
+foreign import ccall "math.h isnan" c_isnanf :: Float -> CInt
+foreign import ccall "math.h isinf" c_isinfinitef :: Float -> CInt
+foreign import ccall "math.h ldexp" c_ldexp :: Double -> CInt -> Double  
+foreign import ccall "math.h signbit" c_signbit :: Double -> CInt
+foreign import ccall "math.h signbit" c_signbitf :: Float -> CInt
+
+foreign import ccall "math.h frexp" c_frexp :: Double -> Ptr CInt -> IO Double  
+
+foreign import primitive "const.FLT_RADIX" c_flt_radix :: Integer
+foreign import primitive "const.FLT_MANT_DIG" c_flt_mant_dig :: Int
+foreign import primitive "const.FLT_MIN_EXP" c_flt_min_exp :: Int
+foreign import primitive "const.FLT_MAX_EXP" c_flt_max_exp :: Int
+foreign import primitive "const.M_PI" c_pif :: Float
+foreign import primitive "const.M_PI" c_pi :: Double
+    
+instance RealFloat Double where 
+    floatRadix _ = c_flt_radix
+    floatDigits _ = c_dbl_mant_dig
+    floatRange _ = (c_dbl_min_exp,c_dbl_max_exp)
+
+    exponent x		= case decodeFloat x of
+			    (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+    significand x	= case decodeFloat x of
+			    (m,_) -> encodeFloat m (negate (floatDigits x))
+
+    --scaleFloat k x	= case decodeFloat x of
+    --    		    (m,n) -> encodeFloat m (n+k)        
+    isNaN x = c_isnan x /= 0
+    isInfinite x = c_isinfinite x /= 0
+    isDenormalized _ = False
+    isNegativeZero x = x == 0 && c_signbit x /= 0 
+    isIEEE _ = True
+    encodeFloat i e =  c_ldexp (integer2double i) (fromInt e) 
+    scaleFloat k x = c_ldexp x (fromInt k)
+    decodeFloat x = unsafePerformIO $ alloca $ \ptr -> do
+        x' <- c_frexp x ptr
+        exp <- peek ptr
+        let x'' = c_ldexp x' (fromInt $ floatDigits x)
+        return (double2integer x'', fromIntegral exp  - floatDigits x)
+
+    
+    
+
+foreign import ccall "math.h isnan" c_isnan :: Double -> CInt
+foreign import ccall "math.h isinf" c_isinfinite :: Double -> CInt
+
+foreign import primitive "const.DBL_MANT_DIG" c_dbl_mant_dig :: Int
+foreign import primitive "const.DBL_MIN_EXP" c_dbl_min_exp :: Int
+foreign import primitive "const.DBL_MAX_EXP" c_dbl_max_exp :: Int
+
+foreign import primitive "integralCast" integer2float :: Integer -> Float
+foreign import primitive "integralCast" integer2double :: Integer -> Double
+foreign import primitive "integralCast" double2float :: Double -> Float
+foreign import primitive "integralCast" double2integer :: Double -> Integer
+foreign import primitive "integralCast" float2double :: Float -> Double
+
addfile ./lib/Prelude.IO.hs
hunk ./lib/Prelude.IO.hs 1
+module Prelude.IO(
+    IO, 
+    module Prelude.IO, 
+    userError) where
+
+import Prelude
+import Prelude.Text
+import Prelude.IOError
+import Jhc.IO
+import Char
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Ptr
+
+
+-- IO operations exported by the prelude
+
+type  FilePath = String
+
+
+
+{-# INLINE runMain, runExpr, ioError, catch #-}
+runMain :: IO a -> IO ()
+--runMain main = do
+--    main
+--    return ()
+--runMain (IO main) = IO $ \w-> case main w of JustIO w' _ -> JustIO w' ()
+runMain main = do
+    catch main  (\e -> do
+        putStr "\nError..\n"
+        putStrLn $ showIOError e 
+        return (error "runMain")) 
+    return ()
+
+runExpr :: Show a => a -> IO ()
+runExpr x = runMain (print x) 
+
+
+ioError    ::  IOError -> IO a 
+ioError e   =  (IO $ \w -> FailIO w e) 
+
+	   
+catch      ::  IO a -> (IOError -> IO a) -> IO a 
+catch (IO x) fn  = IO $ \w -> case x w of
+    JustIO w' z  -> JustIO w' z
+    FailIO w' z -> case fn z of
+        IO f -> f w'
+	   
+	   
+putStr     :: String -> IO ()
+putStr s   =  mapM_ putChar s
+	   
+putStrLn   :: String -> IO ()
+putStrLn s =  do putStr s
+                 putStr "\n"
+	   
+print      :: Show a => a -> IO ()
+print x    =  putStrLn (show x)
+	   
+	   
+getLine    :: IO String
+getLine    =  do c <- getChar
+                 if c == '\n' then return "" else 
+                    do s <- getLine
+                       return (c:s)
+
+getContents :: IO String
+getContents = unsafeInterleaveIO getContents' where  
+    getContents' = do
+        ch <- c_getwchar 
+        case ch of
+            -1 -> return []
+            _ -> do
+                xs <- unsafeInterleaveIO getContents'
+                return (cwintToChar ch:xs)
+            
+{-
+getContents :: IO String
+getContents = return (unsafePerformIO getContents') where  
+    getContents' = do
+        ch <- c_getwchar 
+        case ch of
+            -1 -> return []
+            _ -> return (chr (fromIntegral ch):unsafePerformIO getContents')
+-}    
+    
+readFile :: FilePath -> IO String 
+readFile fn = do
+    file <- withCString fn $ \fnc -> c_fopen fnc read_str
+    if  (file == nullPtr) then (fail "Could not open file.") else do
+        let gc = do
+                ch <- c_fgetwc file
+                case ch of
+                    -1 -> c_fclose file >> return []
+                    _ -> do
+                        xs <- unsafeInterleaveIO gc 
+                        return (cwintToChar ch:xs)
+        unsafeInterleaveIO gc
+
+read_str = unsafePerformIO (newCString "r")
+
+foreign import primitive "integralCast" cwintToChar :: CWint -> Char
+
+foreign import ccall "stdio.h fopen" c_fopen :: CString -> CString -> IO (Ptr ())
+foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt
+foreign import ccall "wchar.h getwc" c_fgetwc :: Ptr () -> IO CWint
+foreign import ccall "wchar.h getwchar" c_getwchar :: IO CWint
+
+-- | The 'interact' function takes a function of type @String->String@
+-- as its argument.  The entire input from the standard input device is
+-- passed to this function as its argument, and the resulting string is
+-- output on the standard output device.
+
+interact        ::  (String -> String) -> IO ()
+interact f      =   do s <- getContents
+                       putStr (f s)             
+{-
+interact    ::  (String -> String) -> IO ()
+-- The hSetBuffering ensures the expected interactive behaviour
+interact f  =  do hSetBuffering stdin  NoBuffering
+                  hSetBuffering stdout NoBuffering
+                  s <- getContents
+                  putStr (f s)
+
+-}
+
+	   
+writeFile  :: FilePath -> String -> IO ()
+writeFile  =  error "writeFile"
+	   
+appendFile :: FilePath -> String -> IO ()
+appendFile =  error "appendFile"
+
+  -- raises an exception instead of an error
+readIO   :: Read a => String -> IO a
+readIO s =  case [x | (x,t) <- reads s, ("","") <- lex t] of
+              [x] -> return x
+              []  -> ioError (userError "Prelude.readIO: no parse")
+              _   -> ioError (userError "Prelude.readIO: ambiguous parse")
+
+readLn :: Read a => IO a
+readLn =  do l <- getLine
+             r <- readIO l
+             return r
+
+putChar :: Char -> IO ()
+putChar c = c_putwchar (fromIntegral (ord c)) 
+
+--TODO EOF == -1 
+getChar :: IO Char
+getChar = do
+    ch <- c_getwchar 
+    case ch of
+        -1 -> fail "End of file."
+        _ -> return (cwintToChar ch)
+
+foreign import ccall "stdio.h putwchar" c_putwchar :: CWchar -> IO ()
+--foreign import ccall "stdio.h getchar_unlocked" c_getchar :: IO CInt
+
+--putChar c = IO $ primPutChar c
+--getChar = IO primGetChar
+
+--foreign import primitive primPutChar :: Char -> World__ -> IOResult ()
+--foreign import primitive primGetChar :: World__ -> IOResult Char
+
addfile ./lib/Prelude.IOError.hs
hunk ./lib/Prelude.IOError.hs 1
+module Prelude.IOError where
+
+
+newtype IOError = IOError String
+    deriving(Show,Eq)
+
+showIOError :: IOError -> String
+showIOError (IOError x) = x
+
+{-
+data IOError = IOError {
+     ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging 
+				     -- the error.
+     ioe_type     :: IOErrorType,    -- what it was.
+     ioe_location :: String,	     -- location.
+     ioe_description :: String,      -- error type specific information.
+     ioe_filename :: Maybe FilePath  -- filename the error is related to.
+   } deriving(Eq)
+
+
+-- | An abstract type that contains a value for each variant of 'IOError'.
+data IOErrorType
+  = AlreadyExists
+  | NoSuchThing
+  | ResourceBusy
+  | ResourceExhausted
+  | EOF
+  | IllegalOperation
+  | PermissionDenied
+  | UserError                
+
+instance Show IOErrorType where
+  showsPrec _ e =
+    showString $
+    case e of
+      AlreadyExists	-> "already exists"
+      NoSuchThing       -> "does not exist"
+      ResourceBusy      -> "resource busy"
+      ResourceExhausted -> "resource exhausted"
+      EOF		-> "end of file"
+      IllegalOperation	-> "illegal operation"
+      PermissionDenied  -> "permission denied"
+      UserError		-> "user error"              
+
+instance Show IOException where
+    showsPrec p (IOError hdl iot loc s fn) =
+      (case fn of
+	 Nothing -> case hdl of
+		        Nothing -> id
+			Just h  -> showsPrec p h . showString ": "
+	 Just name -> showString name . showString ": ") .
+      (case loc of
+         "" -> id
+	 _  -> showString loc . showString ": ") .
+      showsPrec p iot . 
+      (case s of
+	 "" -> id
+	 _  -> showString " (" . showString s . showString ")")               
+
+-}
+
+userError       :: String  -> IOError
+userError str	=  IOError  str 
addfile ./lib/Prelude.Ratio.hs
hunk ./lib/Prelude.Ratio.hs 1
+
+module Prelude.Ratio where
+
+data  (Integral a)      => Ratio a = !a :% !a  
+type  Rational          =  Ratio Integer
+
+-- "reduce" is a subsidiary function used only in this module.
+-- It normalises a ratio by dividing both numerator
+-- and denominator by their greatest common divisor.
+--
+-- E.g., 12 `reduce` 8    ==  3 :%   2
+--       12 `reduce` (-8) ==  3 :% (-2)
+
+reduce _ 0              =  error "Ratio.% : zero denominator"
+reduce x y              =  (x `quot` d) :% (y `quot` d)
+                           where d = gcd x y
+
+instance  (Integral a)  => Ord (Ratio a)  where
+    (x:%y) <= (x':%y')  =  x * y' <= x' * y
+    (x:%y) <  (x':%y')  =  x * y' <  x' * y
+    
+--negateRatio (x:%y)       =  (-x) :% y
+--(x:%y) `plusRatio` (x':%y')   =  reduce ((x*y') + (x'*y)) (y*y')
+--absRatio (x:%y)          =  abs x :% y
+
+instance  (Integral a)  => Num (Ratio a)  where
+    --(+) = plusRatio
+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')
+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')
+    --negate x {-(x:%y)-}   =  negateRatio x -- (-x) :% y
+    negate (x:%y)       =  (-x) :% y
+    --abs (x:%y)        =  abs x :% y
+    abs (x:%y)          =  abs x :% y
+    signum (x:%y)       =  signum x :% 1
+    fromInteger x       =  fromInteger x :% 1
+
+instance  (Integral a)  => Real (Ratio a)  where
+    toRational (x:%y)   =  toInteger x :% toInteger y
+
+instance  (Integral a)  => Fractional (Ratio a)  where
+    (x:%y) / (x':%y')   =  (x*y') % (y*x')
+    recip (x:%y)        =  y % x
+    fromRational (x:%y) =  fromInteger x :% fromInteger y
+
+instance  (Integral a)  => RealFrac (Ratio a)  where
+    properFraction (x:%y) = (fromIntegral q, r:%y)
+                            where (q,r) = quotRem x y
+
+{-
+instance  (Integral a)  => Enum (Ratio a)  where
+    succ x           =  x+1
+    pred x           =  x-1
+    toEnum           =  fromIntegral
+    fromEnum         =  fromInteger . truncate	-- May overflow
+--    enumFrom         =  numericEnumFrom		-- These numericEnumXXX functions
+--    enumFromThen     =  numericEnumFromThen	-- are as defined in Prelude.hs
+--    enumFromTo       =  numericEnumFromTo	-- but not exported from it!
+--    enumFromThenTo   =  numericEnumFromThenTo
+-}
+
+instance  (Read a, Integral a)  => Read (Ratio a)  where
+    readsPrec p  =  readParen (p > ratPrec)
+                              (\r -> [(reduce (x * signum y) (abs y),u) | (x,s)   <- readsPrec (ratPrec+1) r,
+                                                ("%",t) <- lex s,
+                                                (y,u)   <- readsPrec (ratPrec+1) t ])
+
+instance  (Integral a)  => Show (Ratio a)  where
+    showsPrec p (x:%y)  =  showParen (p > ratPrec)
+                               (showsPrec (ratPrec+1) x . 
+			        showString " % " . 
+				showsPrec (ratPrec+1) y)
+
addfile ./lib/Prelude.Text.hs
hunk ./lib/Prelude.Text.hs 1
+module Prelude.Text (
+    ReadS, ShowS,
+    Read(readsPrec, readList),
+    Show(showsPrec, show, showList),
+    reads, shows, read, lex,
+    showChar, showString, readParen, showParen ) where
+
+-- The instances of Read and Show for
+--      Bool, Maybe, Either, Ordering
+-- are done via "deriving" clauses in Prelude.hs
+import Prelude
+
+
+import Char(isSpace, isAlpha, isDigit, isAlphaNum,
+            showLitChar, readLitChar, lexLitChar)
+
+import Numeric(showSigned, showInt, readSigned, readDec, showFloat,
+               readFloat, lexDigits)
+
+type  ReadS a  = String -> [(a,String)]
+type  ShowS    = String -> String
+
+class  Read a  where
+    readsPrec        :: Int -> ReadS a
+    readList         :: ReadS [a]
+
+        -- Minimal complete definition:
+        --      readsPrec
+    readList         = readParen False (\r -> [pr | ("[",s)  <- lex r,
+                                                    pr       <- readl s])
+                       where readl  s = [([],t)   | ("]",t)  <- lex s] ++
+                                        [(x:xs,u) | (x,t)    <- reads s,
+                                                    (xs,u)   <- readl' t]
+                             readl' s = [([],t)   | ("]",t)  <- lex s] ++
+                                        [(x:xs,v) | (",",t)  <- lex s,
+                                                    (x,u)    <- reads t,
+                                                    (xs,v)   <- readl' u]
+
+class  Show a  where
+    showsPrec        :: Int -> a -> ShowS
+    show             :: a -> String 
+    showList         :: [a] -> ShowS
+
+        -- Mimimal complete definition:
+        --      show or showsPrec
+    showsPrec _ x s   = show x ++ s
+
+    show x            = showsPrec 0 x ""
+
+    showList []       = showString "[]"
+    showList (x:xs)   = showChar '[' . shows x . showl xs
+                        where showl []     = showChar ']'
+                              showl (x:xs) = showChar ',' . shows x .
+                                             showl xs
+
+reads            :: (Read a) => ReadS a
+reads            =  readsPrec 0
+
+shows            :: (Show a) => a -> ShowS
+shows            =  showsPrec 0
+
+read             :: (Read a) => String -> a
+read s           =  case [x | (x,t) <- reads s, ("","") <- lex t] of
+                         [x] -> x
+                         []  -> error "Prelude.read: no parse"
+                         _   -> error "Prelude.read: ambiguous parse"
+
+{-# INLINE showChar, showString #-}
+showChar         :: Char -> ShowS
+showChar         =  (:)
+
+showString       :: String -> ShowS
+showString       =  (++)
+
+showParen        :: Bool -> ShowS -> ShowS
+showParen b p    =  if b then showChar '(' . p . showChar ')' else p
+
+readParen        :: Bool -> ReadS a -> ReadS a
+readParen b g    =  if b then mandatory else optional
+                    where optional r  = g r ++ mandatory r
+                          mandatory r = [(x,u) | ("(",s) <- lex r,
+                                                 (x,t)   <- optional s,
+                                                 (")",u) <- lex t    ]
+
+-- This lexer is not completely faithful to the Haskell lexical syntax.
+-- Current limitations:
+--    Qualified names are not handled properly
+--    Octal and hexidecimal numerics are not recognized as a single token
+--    Comments are not treated properly
+
+lex              :: ReadS String
+lex ""           =  [("","")]
+lex (c:s)
+   | isSpace c   =  lex (dropWhile isSpace s)
+lex ('\'':s)     =  [('\'':ch++"'", t) | (ch,'\'':t)  <- lexLitChar s,
+                                         ch /= "'" ]
+lex ('"':s)      =  [('"':str, t)      | (str,t) <- lexString s]
+                    where
+                    lexString ('"':s) = [("\"",s)]
+                    lexString s = [(ch++str, u)
+                                         | (ch,t)  <- lexStrItem s,
+                                           (str,u) <- lexString t  ]
+
+                    lexStrItem ('\\':('&':s)) =  [("\\&",s)]
+                    lexStrItem ('\\':(c:s)) | isSpace c
+                                           =  [("\\&",t) | 
+                                               '\\':t <-
+                                                   [dropWhile isSpace s]]
+                    lexStrItem s           =  lexLitChar s
+
+lex (c:s) | isSingle c = [([c],s)]
+          | isSym c    = [(c:sym,t)       | (sym,t) <- [span isSym s]]
+          | isAlpha c  = [(c:nam,t)       | (nam,t) <- [span isIdChar s]]
+          | isDigit c  = [(c:(ds++fe),t)  | (ds,s')  <- [span isDigit s],
+                                            (fe,t)  <- lexFracExp s'     ]
+          | otherwise  = []    -- bad character
+             where
+              isSingle c =  c `elem` ",;()[]{}_`"
+              isSym c    =  c `elem` "!@#$%&*+./<=>?\\^|:-~"
+              isIdChar c =  isAlphaNum c || c `elem` "_'"
+
+              lexFracExp ('.':(c:cs)) | isDigit c
+                            = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
+                                               (e,u)  <- lexExp t]
+              lexFracExp s  = lexExp s
+
+              lexExp (e:s) | e `elem` "eE"
+                       = [(e:c:ds,u) | (c:t)  <- [s], c `elem` "+-",
+                                                 (ds,u) <- lexDigits t] ++
+                         [(e:ds,t)   | (ds,t) <- lexDigits s]
+              lexExp s = [("",s)]
+
+instance  Show Int  where
+    showsPrec n = showsPrec n . toInteger
+        -- Converting to Integer avoids
+        -- possible difficulty with minInt
+
+instance  Read Int  where
+  readsPrec p r = [(fromInteger i, t) | (i,t) <- readsPrec p r]
+        -- Reading at the Integer type avoids
+        -- possible difficulty with minInt
+
+instance  Show Integer  where
+    showsPrec           = showSigned showInt
+
+instance  Read Integer  where
+    readsPrec p         = readSigned readDec
+
+instance  Show Float  where 
+    showsPrec p         = showFloat
+           
+instance  Read Float  where
+    readsPrec p         = readSigned readFloat
+
+instance  Show Double  where
+    showsPrec p         = showFloat
+
+instance  Read Double  where
+    readsPrec p         = readSigned readFloat
+
+instance  Show ()  where
+    showsPrec p () = showString "()"
+
+instance Read () where
+    readsPrec p    = readParen False
+                            (\r -> [((),t) | ("(",s) <- lex r,
+                                             (")",t) <- lex s ] )
+instance  Show Char  where
+    showsPrec p '\'' = showString "'\\''"
+    showsPrec p c    = showChar '\'' . showLitChar c . showChar '\''
+
+    showList cs = showChar '"' . showl cs
+                 where showl ""       = showChar '"'
+                       showl ('"':cs) = showString "\\\"" . showl cs
+                       showl (c:cs)   = showLitChar c . showl cs
+
+instance  Read Char  where
+    readsPrec p      = readParen False
+                            (\r -> [(c,t) | ('\'':s,t)<- lex r,
+                                            (c,"\'")  <- readLitChar s])
+
+    readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
+                                               (l,_)      <- readl s ])
+        where readl ('"':s)      = [("",s)]
+              readl ('\\':('&':s)) = readl s
+              readl s            = [(c:cs,u) | (c ,t) <- readLitChar s,
+                                               (cs,u) <- readl t       ]
+
+instance  (Show a) => Show [a]  where
+    showsPrec p      = showList
+
+instance  (Read a) => Read [a]  where
+    readsPrec p      = readList
+
+    
+    {-
+instance Show a => Show (Maybe a) where
+    showsPrec _p Nothing s = showString "Nothing" s
+    showsPrec p (Just x) s
+                          = (showParen (p > 10) $ 
+    			     showString "Just " . 
+			     showsPrec 11 x) s
+
+instance (Show a, Show b) => Show (Either a b) where
+    showsPrec p e s =
+       (showParen (p > 10) $
+        case e of
+         Left  a -> showString "Left "  . showsPrec 11 a
+	 Right b -> showString "Right " . showsPrec 11 b)
+       s            
+    -}
+
+-- Tuples
+{-
+
+instance  (Show a, Show b) => Show (a,b)  where
+    showsPrec p (x,y) = showChar '(' . shows x . showChar ',' .
+                                       shows y . showChar ')'
+
+instance  (Read a, Read b) => Read (a,b)  where
+    readsPrec p       = readParen False
+                            (\r -> [((x,y), w) | ("(",s) <- lex r,
+                                                 (x,t)   <- reads s,
+                                                 (",",u) <- lex t,
+                                                 (y,v)   <- reads u,
+                                                 (")",w) <- lex v ] )
+
+instance  (Show a, Show b) => Show (a,b)  where
+    showsPrec _ (x,y) s = (showChar '(' . shows x . showChar ',' .
+                                          shows y . showChar ')') 
+			  s
+
+instance (Show a, Show b, Show c) => Show (a, b, c) where
+    showsPrec _ (x,y,z) s = (showChar '(' . shows x . showChar ',' .
+					    shows y . showChar ',' .
+					    shows z . showChar ')')
+			    s
+
+instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
+    showsPrec _ (w,x,y,z) s = (showChar '(' . shows w . showChar ',' .
+					      shows x . showChar ',' .
+					      shows y . showChar ',' .
+					      shows z . showChar ')')
+			      s
+
+instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
+    showsPrec _ (v,w,x,y,z) s = (showChar '(' . shows v . showChar ',' .
+					     	shows w . showChar ',' .
+					     	shows x . showChar ',' .
+					     	shows y . showChar ',' .
+					     	shows z . showChar ')') 
+				s                                                      
+-- Other tuples have similar Read and Show instances
+
+-}
+
+ 
addfile ./lib/Prelude.hs
hunk ./lib/Prelude.hs 1
+module Prelude(module Prelude,  IO, IOError, putStr, putStrLn, module Prelude.IO, module Prelude.Text, Rational) where
+
+import Prelude.IO
+import Prelude.IOError
+import Prelude.Text
+import Prelude.Float
+import Ratio
+import qualified Char(isSpace,ord,chr)
+import Jhc.IO
+import Jhc.Tuples
+
+
+infixr 9  .
+infixr 8  ^, ^^, **
+infixl 7  *  , /, `quot`, `rem`, `div`, `mod`
+infixl 6  +, -
+infixr 5  :
+infix  4  ==, /=, <, <=, >=, >
+infixr 3  &&
+infixr 2  ||
+infixl 1  >>, >>=
+infixr 1  =<<
+infixr 0  $, $!, `seq`
+
+
+
+data Bool = False | True
+    deriving (Eq, Ord, Bounded, Enum, Read, Show)
+
+data () = ()
+    deriving (Eq, Ord, Bounded, Enum, Show)  -- Read declared in Prelude.Text
+
+data [] a =  a : ([] a) | []
+    -- odd syntax, so we write instances manually
+
+data  Ordering    =  LT | EQ | GT 
+    deriving (Eq, Ord, Bounded, Enum, Read, Show)
+
+
+data (,) a b = (,) a b                        
+data (,,) a b c = (,,) a b c                    
+data (,,,) a b c d = (,,,) a b c d                 
+data (,,,,) a b c d e = (,,,,) a b c d e             
+data (,,,,,) a b c d e f = (,,,,,) a b c d e f
+data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g
+data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h
+data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i
+
+type String = [Char]     
+data Integer
+data Int                  
+data Char               
+data Float               
+data Double
+
+-- Enumeration and Bounded classes
+
+class  Enum a  where
+    succ, pred       :: a -> a
+    toEnum           :: Int -> a
+    fromEnum         :: a -> Int
+    enumFrom         :: a -> [a]             -- [n..]
+    enumFromThen     :: a -> a -> [a]        -- [n,n'..]
+    enumFromTo       :: a -> a -> [a]        -- [n..m]
+    enumFromThenTo   :: a -> a -> a -> [a]   -- [n,n'..m]
+
+        -- Minimal complete definition:
+        --      toEnum, fromEnum
+--
+-- NOTE: these default methods only make sense for types
+--   that map injectively into Int using fromEnum
+--  and toEnum.
+    succ             =  toEnum . (+1) . fromEnum
+    pred             =  toEnum . (subtract 1) . fromEnum
+    enumFrom x       =  map toEnum [fromEnum x ..]
+    enumFromTo x y   =  map toEnum [fromEnum x .. fromEnum y]
+    enumFromThen x y =  map toEnum [fromEnum x, fromEnum y ..]
+    enumFromThenTo x y z = 
+                        map toEnum [fromEnum x, fromEnum y .. fromEnum z]
+
+
+class Bounded a  where
+    minBound         :: a
+    maxBound         :: a
+
+-- Numeric classes
+
+
+class  (Eq a, Show a) => Num a  where
+    (+), (-), (*)    :: a -> a -> a
+    negate           :: a -> a
+    abs, signum      :: a -> a
+    fromInteger      :: Integer -> a
+    fromInt          :: Int -> a
+--    fromIntMax       :: IntMax -> a
+--    fromWordMax      :: WordMax -> a
+
+        -- Minimal complete definition:
+        --      All, except negate or (-)
+    x - y            =  x + negate y
+    negate x         =  0 - x
+    fromInt i = fromInteger (toInteger i)
+    fromInteger x = fromInt (toInt x)
+
+
+class  (Num a, Ord a) => Real a  where
+    toRational       ::  a -> Rational
+
+
+class  (Real a, Enum a) => Integral a  where
+    quot, rem        :: a -> a -> a   
+    div, mod         :: a -> a -> a
+    quotRem, divMod  :: a -> a -> (a,a)
+    toInteger        :: a -> Integer
+    toInt            :: a -> Int
+--    toIntMax         :: a -> IntMax
+--    toWordMax        :: a -> WordMax
+
+        -- Minimal complete definition:
+        --      quotRem, toInteger
+    n `quot` d       =  q  where (q,r) = quotRem n d
+    n `rem` d        =  r  where (q,r) = quotRem n d
+    n `div` d        =  q  where (q,r) = divMod n d
+    n `mod` d        =  r  where (q,r) = divMod n d
+    divMod n d       =  if signum r == - signum d then (q-1, r+d) else qr
+                        where qr@(q,r) = quotRem n d
+    quotRem n d       =  (n `quot` d, n `rem` d)
+    --toInteger x = Integer (toInt x)
+    --toInt x = case toInteger x of
+    --    Integer y -> y
+    toInteger x = toInteger (toInt x)
+    toInt x = toInt (toInteger x) 
+    --toIntMax x = toIntMax (toInteger x)
+    --toWordMax x = toWordMax (toInteger x)
+
+
+class  (Num a) => Fractional a  where
+    (/)              :: a -> a -> a
+    recip            :: a -> a
+    fromRational     :: Rational -> a
+
+        -- Minimal complete definition:
+        --      fromRational and (recip or (/))
+    recip x          =  1 / x
+    x / y            =  x * recip y
+
+
+class  (Fractional a) => Floating a  where
+    pi                  :: a
+    exp, log, sqrt      :: a -> a
+    (**), logBase       :: a -> a -> a
+    sin, cos, tan       :: a -> a
+    asin, acos, atan    :: a -> a
+    sinh, cosh, tanh    :: a -> a
+    asinh, acosh, atanh :: a -> a
+
+        -- Minimal complete definition:
+        --      pi, exp, log, sin, cos, sinh, cosh
+        --      asin, acos, atan
+        --      asinh, acosh, atanh
+    x ** y           =  exp (log x * y)
+    logBase x y      =  log y / log x
+    sqrt x           =  x ** (1 / 2) -- 0.5        -- TODO Doubles
+    tan  x           =  sin  x / cos  x
+    tanh x           =  sinh x / cosh x
+
+
+
+-- TODO Doubles
+class  (Real a, Fractional a) => RealFrac a  where
+    properFraction   :: (Integral b) => a -> (b,a)
+    truncate, round  :: (Integral b) => a -> b
+    ceiling, floor   :: (Integral b) => a -> b
+
+        -- Minimal complete definition:
+        --      properFraction
+    truncate x       =  m  where (m,_) = properFraction x
+    
+    round x          =  let (n,r) = properFraction x
+                            m     = if r < 0 then n - 1 else n + 1
+                          in case signum (abs r - 0.5) of
+                                -1 -> n
+                                0  -> if even n then n else m
+                                1  -> m
+   
+    ceiling x        =  if r > 0 then n + 1 else n
+                        where (n,r) = properFraction x
+    
+    floor x          =  if r < 0 then n - 1 else n
+                        where (n,r) = properFraction x
+
+
+-- TODO Doubles
+class  (RealFrac a, Floating a) => RealFloat a  where
+    floatRadix       :: a -> Integer
+    floatDigits      :: a -> Int
+    floatRange       :: a -> (Int,Int)
+    decodeFloat      :: a -> (Integer,Int)
+    encodeFloat      :: Integer -> Int -> a
+    exponent         :: a -> Int
+    significand      :: a -> a
+    scaleFloat       :: Int -> a -> a
+    isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+                     :: a -> Bool
+    atan2            :: a -> a -> a
+
+        -- Minimal complete definition:
+        --      All except exponent, significand, 
+        --                 scaleFloat, atan2
+    exponent x       =  if m == 0 then 0 else n + floatDigits x
+                        where (m,n) = decodeFloat x
+
+    significand x    =  encodeFloat m (- floatDigits x)
+                        where (m,_) = decodeFloat x
+
+    scaleFloat k x   =  encodeFloat m (n+k)
+                        where (m,n) = decodeFloat x
+
+    atan2 y x
+      | x>0           =  atan (y/x)
+      | x==0 && y>0   =  pi/2
+      | x<0  && y>0   =  pi + atan (y/x) 
+      |(x<=0 && y<0)  ||
+       (x<0 && isNegativeZero y) ||
+       (isNegativeZero x && isNegativeZero y)
+                      = -atan2 (-y) x
+      | y==0 && (x<0 || isNegativeZero x)
+                      =  pi    -- must be after the previous test on zero y
+      | x==0 && y==0  =  y     -- must be after the other double zero tests
+      | otherwise     =  x + y -- x or y is a NaN, return a NaN (via +)
+
+ 
+-- Numeric functions
+
+
+subtract         :: (Num a) => a -> a -> a
+subtract         =  flip (-)
+
+
+even, odd        :: (Integral a) => a -> Bool
+even n           =  n `rem` 2 == 0
+odd              =  not . even
+
+
+gcd              :: (Integral a) => a -> a -> a
+gcd 0 0          =  error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y          =  gcd' (abs x) (abs y)
+                    where gcd' x 0  =  x
+                          gcd' x y  =  gcd' y (x `rem` y)
+
+
+lcm              :: (Integral a) => a -> a -> a
+lcm _ 0          =  0
+lcm 0 _          =  0
+lcm x y          =  abs ((x `quot` (gcd x y)) * y)
+
+
+(^)              :: (Num a, Integral b) => a -> b -> a
+x ^ 0            =  1
+x ^ n | n > 0    =  f x (n-1) x
+                    where f _ 0 y = y
+                          f x n y = g x n  where
+                                    g x n | even n  = g (x*x) (n `quot` 2)
+                                          | otherwise = f x (n-1) (x*y)
+_ ^ _            = error "Prelude.^: negative exponent"
+
+
+(^^)             :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n           =  if n >= 0 then x^n else recip (x^(-n))
+
+
+{-# INLINE fromIntegral, realToFrac #-}
+fromIntegral     :: (Integral a, Num b) => a -> b
+fromIntegral     =  fromInteger . toInteger
+
+
+realToFrac     :: (Real a, Fractional b) => a -> b
+realToFrac      =  fromRational . toRational
+
+ -- Monadic classes
+
+class Functor f  where
+    fmap              :: (a -> b) -> f a -> f b
+
+{- INLINE return, fail, (>>=), (>>) -}
+class Monad m  where
+    (>>=)  :: m a -> (a -> m b) -> m b
+    (>>)   :: m a -> m b -> m b
+    return :: a -> m a
+    fail   :: String -> m a
+
+        -- Minimal complete definition:
+        --      (>>=), return
+    m >> k  =  m >>= \_ -> k
+    fail s  = error s
+
+sequence       :: Monad m => [m a] -> m [a] 
+sequence       =  foldr mcons (return [])
+                    where mcons p q = p >>= \x -> q >>= \y -> return (x:y)
+sequence_      :: Monad m => [m a] -> m () 
+sequence_      =  foldr (>>) (return ())
+
+-- The xxxM functions take list arguments, but lift the function or
+-- list element to a monad type
+
+mapM             :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f as        =  sequence (map f as)
+
+mapM_            :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f as       =  sequence_ (map f as)
+
+(=<<)            :: Monad m => (a -> m b) -> m a -> m b
+f =<< x          =  x >>= f
+
+
+
+    
+instance Monad Maybe where
+    return x = Just x
+    Nothing >>= _ = Nothing
+    Just x >>= y = y x
+    fail _ = Nothing
+
+instance Monad [] where
+    return x = [x]
+    xs >>= f = concatMap f xs
+    fail _ = []
+
+
+
+
+class Eq a where
+    (==) :: a -> a -> Bool
+    (/=) :: a -> a -> Bool
+    x == y = case x /= y of 
+        True -> False
+        False -> True
+    x /= y = case x == y of
+        True -> False 
+        False -> True
+
+class  (Eq a) => Ord a  where
+    compare              :: a -> a -> Ordering
+    (<), (<=), (>=), (>) :: a -> a -> Bool
+    max, min             :: a -> a -> a
+
+    compare x y | x == y    = EQ
+                | x <= y    = LT
+                | otherwise = GT
+
+    x <= y  = compare x y /= GT
+    x <  y  = compare x y == LT
+    x >= y  = compare x y /= LT
+    x >  y  = compare x y == GT
+
+    -- Note that (min x y, max x y) = (x,y) or (y,x)
+    max x y | x <= y    =  y
+            | otherwise =  x
+    min x y | x <= y    =  x
+            | otherwise =  y
+
+
+instance Functor [] where
+    fmap f (x:xs) = f x : fmap f xs
+    fmap f [] = []
+
+
+{-
+instance Eq Bool where
+    True == True = True
+    False == False = True
+    _ == _ = False
+-}
+
+undefined :: a
+undefined = error "Prelude.undefined"
+
+-- Basic combinators
+
+{-# INLINE id, const, (.), ($), ($!), flip #-}
+
+id x = x
+const x _ = x
+f . g = \x -> f (g x)
+f $ x = f x
+f $! x = x `seq` f x
+flip f x y = f y x
+
+{-# INLINE (&&), (||), not, otherwise #-}
+(&&), (||)       :: Bool -> Bool -> Bool
+True  && x       =  x
+False && _       =  False
+True  || _       =  True
+False || x       =  x
+                                        
+
+not              :: Bool -> Bool
+not x = if x then False else True
+
+
+otherwise        :: Bool
+otherwise        =  True
+
+-- Maybe
+
+data Maybe a  =  Nothing | Just a
+    deriving (Eq, Ord, Read, Show)
+    
+
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f m = case m of
+    Just x -> f x
+    Nothing -> n
+
+data Either a b = Left a | Right b
+    deriving (Eq, Ord, Read, Show)
+
+
+{-# INLINE fst, snd #-}
+fst (a,b) = a
+snd (a,b) = b
+
+
+
+
+
+
+until            :: (a -> Bool) -> (a -> a) -> a -> a
+until p f x 
+     | p x       =  x
+     | otherwise =  until p f (f x)
+
+-- asTypeOf is a type-restricted version of const.  It is usually used
+-- as an infix operator, and its typing forces its first argument
+-- (which is usually overloaded) to have the same type as the second.
+
+{-# INLINE asTypeOf #-}
+asTypeOf         :: a -> a -> a
+asTypeOf         =  const
+
+
+
+
+ 
+-- module PreludeList (
+--    map, (++), filter, concat, concatMap, 
+--    head, last, tail, init, null, length, (!!), 
+--    foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+--    iterate, repeat, replicate, cycle,
+--    take, drop, splitAt, takeWhile, dropWhile, span, break,
+--    lines, words, unlines, unwords, reverse, and, or,
+--    any, all, elem, notElem, lookup,
+--    sum, product, maximum, minimum, 
+--    zip, zip3, zipWith, zipWith3, unzip, unzip3)
+--  where
+
+
+infixl 9  !!
+infixr 5  ++
+infix  4  `elem`, `notElem`
+
+-- Map and append
+
+map :: (a -> b) -> [a] -> [b]
+map f xs = go xs where
+    go [] = []
+    go (x:xs) = f x : go xs
+
+--map f []     = []
+--map f (x:xs) = f x : map f xs
+
+
+(++) :: [a] -> [a] -> [a]
+[]     ++ ys = ys
+(x:xs) ++ ys = x : (xs ++ ys)
+
+
+filter :: (a -> Bool) -> [a] -> [a]
+filter p []                 = []
+filter p (x:xs) | p x       = x : filter p xs
+                | otherwise = filter p xs
+
+
+concat :: [[a]] -> [a]
+concat xss = foldr (++) [] xss
+
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = foldr ((++) . f) []
+--concatMap f = concat . map f
+
+-- head and tail extract the first element and remaining elements,
+-- respectively, of a list, which must be non-empty.  last and init
+-- are the dual functions working from the end of a finite list,
+-- rather than the beginning.
+
+
+{-# INLINE head, tail, null #-}
+head             :: [a] -> a
+head (x:_)       =  x
+head []          =  error "Prelude.head: empty list"
+
+
+tail             :: [a] -> [a]
+tail (_:xs)      =  xs
+tail []          =  error "Prelude.tail: empty list"
+
+
+last             :: [a] -> a
+last [x]         =  x
+last (_:xs)      =  last xs
+last []          =  error "Prelude.last: empty list"
+
+
+init             :: [a] -> [a]
+init [x]         =  []
+init (x:xs)      =  x : init xs
+init []          =  error "Prelude.init: empty list"
+
+
+null             :: [a] -> Bool
+null []          =  True
+null (_:_)       =  False
+
+-- length returns the length of a finite list as an Int.
+
+length           :: [a] -> Int
+length xs = f xs 0 where
+    f [] n = n
+    f (_:xs) n = f xs $! n + 1
+--length []        =  0
+--length (_:l)     =  1 + length l
+
+-- List index (subscript) operator, 0-origin
+
+(!!)                :: [a] -> Int -> a
+--xs     !! n | n < 0 =  error "Prelude.!!: negative index"
+--[]     !! _         =  error "Prelude.!!: index too large"
+--(x:_)  !! 0         =  x
+--(_:xs) !! n         =  xs !! (n-1)
+
+xs !! n | n < 0   =  error "Prelude.(!!): negative index\n"
+	| otherwise =  sub xs n where
+			    sub :: [a] -> Int -> a
+                            sub []     _ = error "Prelude.(!!): index too large\n"
+                            sub (y:ys) n = if n == 0
+					   then y
+					   else sub ys $! (n - 1)
+
+-- foldl, applied to a binary operator, a starting value (typically the
+-- left-identity of the operator), and a list, reduces the list using
+-- the binary operator, from left to right:
+--  foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
+-- foldl1 is a variant that has no starting value argument, and  thus must
+-- be applied to non-empty lists.  scanl is similar to foldl, but returns
+-- a list of successive reduced values from the left:
+--      scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+-- Note that  last (scanl f z xs) == foldl f z xs.
+-- scanl1 is similar, again without the starting element:
+--      scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+
+
+foldl            :: (a -> b -> a) -> a -> [b] -> a
+foldl f z []     =  z
+foldl f z (x:xs) =  foldl f (f z x) xs
+
+
+foldl1           :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs)  =  foldl f x xs
+foldl1 _ []      =  error "Prelude.foldl1: empty list"
+
+
+scanl            :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q xs     =  q : (case xs of
+                            []   -> []
+                            x:xs -> scanl f (f q x) xs)
+
+
+scanl1           :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs)  =  scanl f x xs
+scanl1 _ []      =  []
+
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
+-- above functions.
+
+
+foldr            :: (a -> b -> b) -> b -> [a] -> b
+--foldr f z []     =  z
+--foldr f z (x:xs) =  f x (foldr f z xs)
+
+-- this version inlines better
+foldr k z xs = go xs where
+    go [] = z
+    go (y:ys) = y `k` go ys
+
+
+foldr1           :: (a -> a -> a) -> [a] -> a
+foldr1 f [x]     =  x
+foldr1 f (x:xs)  =  f x (foldr1 f xs)
+foldr1 _ []      =  error "Prelude.foldr1: empty list"
+
+
+scanr             :: (a -> b -> b) -> b -> [a] -> [b]
+scanr f q0 []     =  [q0]
+scanr f q0 (x:xs) =  f x q : qs where qs@(q:_) = scanr f q0 xs 
+
+
+scanr1          :: (a -> a -> a) -> [a] -> [a]
+scanr1 f []     =  []
+scanr1 f [x]    =  [x]
+scanr1 f (x:xs) =  f x q : qs where qs@(q:_) = scanr1 f xs 
+
+-- iterate f x returns an infinite list of repeated applications of f to x:
+-- iterate f x == [x, f x, f (f x), ...]
+
+iterate          :: (a -> a) -> a -> [a]
+iterate f x      =  x : iterate f (f x)
+
+-- repeat x is an infinite list, with x the value of every element.
+
+repeat           :: a -> [a]
+repeat x         =  xs where xs = x:xs
+
+-- replicate n x is a list of length n with x the value of every element
+
+replicate        :: Int -> a -> [a]
+replicate n x    =  take n (repeat x)
+
+-- cycle ties a finite list into a circular one, or equivalently,
+-- the infinite repetition of the original list.  It is the identity
+-- on infinite lists.
+
+
+cycle            :: [a] -> [a]
+cycle []         =  error "Prelude.cycle: empty list"
+cycle xs         =  xs' where xs' = xs ++ xs'
+
+-- take n, applied to a list xs, returns the prefix of xs of length n,
+-- or xs itself if n > length xs.  drop n xs returns the suffix of xs
+-- after the first n elements, or [] if n > length xs.  splitAt n xs
+-- is equivalent to (take n xs, drop n xs).
+
+
+take                   :: Int -> [a] -> [a]
+take n _      | n <= 0 =  []
+take _ []              =  []
+take n (x:xs)          =  x : take (n-1) xs
+
+
+drop                   :: Int -> [a] -> [a]
+drop n xs     | n <= 0 =  xs
+drop _ []              =  []
+drop n (_:xs)          =  drop (n-1) xs
+
+
+splitAt                  :: Int -> [a] -> ([a],[a])
+splitAt n xs             =  (take n xs, drop n xs)
+
+-- takeWhile, applied to a predicate p and a list xs, returns the longest
+-- prefix (possibly empty) of xs of elements that satisfy p.  dropWhile p xs
+-- returns the remaining suffix.  span p xs is equivalent to 
+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
+
+
+takeWhile               :: (a -> Bool) -> [a] -> [a]
+takeWhile p []          =  []
+takeWhile p (x:xs) 
+            | p x       =  x : takeWhile p xs
+            | otherwise =  []
+
+
+dropWhile               :: (a -> Bool) -> [a] -> [a]
+dropWhile p []          =  []
+dropWhile p xs@(x:xs')
+            | p x       =  dropWhile p xs'
+            | otherwise =  xs
+
+
+span, break             :: (a -> Bool) -> [a] -> ([a],[a])
+span p []            = ([],[])
+span p xs@(x:xs') 
+            | p x       =  (x:ys,zs) 
+            | otherwise =  ([],xs)
+                           where (ys,zs) = span p xs'
+
+break p                 =  span (not . p)
+
+-- lines breaks a string up into a list of strings at newline characters.
+-- The resulting strings do not contain newlines.  Similary, words
+-- breaks a string up into a list of words, which were delimited by
+-- white space.  unlines and unwords are the inverse operations.
+-- unlines joins lines with terminating newlines, and unwords joins
+-- words with separating spaces.
+
+
+lines            :: String -> [String]
+lines ""         =  []
+lines s          =  let (l, s') = break (== '\n') s
+                      in  l : case s' of
+                                []      -> []
+                                (_:s'') -> lines s''
+
+
+words            :: String -> [String]
+words s          =  case dropWhile Char.isSpace s of
+                      "" -> []
+                      s' -> w : words s''
+                            where (w, s'') = break Char.isSpace s'
+
+
+unlines          :: [String] -> String
+unlines          =  concatMap (++ "\n")
+
+
+unwords          :: [String] -> String
+unwords []       =  ""
+unwords ws       =  foldr1 (\w s -> w ++ ' ':s) ws
+
+-- reverse xs returns the elements of xs in reverse order.  xs must be finite.
+
+reverse          :: [a] -> [a]
+--reverse          =  foldl (flip (:)) []
+reverse l =  rev l [] where
+    rev []     a = a
+    rev (x:xs) a = rev xs (x:a)
+
+-- and returns the conjunction of a Boolean list.  For the result to be
+-- True, the list must be finite; False, however, results from a False
+-- value at a finite index of a finite or infinite list.  or is the
+-- disjunctive dual of and.
+
+and, or          :: [Bool] -> Bool
+and              =  foldr (&&) True
+or               =  foldr (||) False
+
+-- Applied to a predicate and a list, any determines if any element
+-- of the list satisfies the predicate.  Similarly, for all.
+
+any, all         :: (a -> Bool) -> [a] -> Bool
+any p            =  or . map p
+all p            =  and . map p
+
+-- elem is the list membership predicate, usually written in infix form,
+-- e.g., x `elem` xs.  notElem is the negation.
+
+elem, notElem    :: (Eq a) => a -> [a] -> Bool
+elem x           =  any (== x)
+notElem x        =  all (/= x)
+
+-- lookup key assocs looks up a key in an association list.
+
+lookup           :: (Eq a) => a -> [(a,b)] -> Maybe b
+lookup key []    =  Nothing
+lookup key ((x,y):xys)
+    | key == x   =  Just y
+    | otherwise  =  lookup key xys
+
+-- sum and product compute the sum or product of a finite list of numbers.
+
+sum, product     :: (Num a) => [a] -> a
+sum              =  foldl (+) 0  
+product          =  foldl (*) 1
+
+-- maximum and minimum return the maximum or minimum value from a list,
+-- which must be non-empty, finite, and of an ordered type.
+
+maximum, minimum :: (Ord a) => [a] -> a
+maximum []       =  error "Prelude.maximum: empty list"
+maximum xs       =  foldl1 max xs
+
+minimum []       =  error "Prelude.minimum: empty list"
+minimum xs       =  foldl1 min xs
+
+-- zip takes two lists and returns a list of corresponding pairs.  If one
+-- input list is short, excess elements of the longer list are discarded.
+-- zip3 takes three lists and returns a list of triples.  Zips for larger
+-- tuples are in the List library
+
+
+zip              :: [a] -> [b] -> [(a,b)]
+zip              =  zipWith (\a b -> (a,b))
+
+
+zip3             :: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3             =  zipWith3 (\a b c -> (a,b,c))
+
+-- The zipWith family generalises the zip family by zipping with the
+-- function given as the first argument, instead of a tupling function.
+-- For example, zipWith (+) is applied to two lists to produce the list
+-- of corresponding sums.
+
+
+zipWith          :: (a->b->c) -> [a]->[b]->[c]
+zipWith z (a:as) (b:bs)
+                 =  z a b : zipWith z as bs
+zipWith _ _ _    =  []
+
+
+zipWith3         :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z (a:as) (b:bs) (c:cs)
+                 =  z a b c : zipWith3 z as bs cs
+zipWith3 _ _ _ _ =  []
+
+
+-- unzip transforms a list of pairs into a pair of lists.  
+
+
+unzip            :: [(a,b)] -> ([a],[b])
+unzip            =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+
+
+unzip3           :: [(a,b,c)] -> ([a],[b],[c])
+unzip3           =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+                          ([],[],[])
+ 
+
+
+{-# NOINLINE error #-}
+error s = unsafePerformIO $ do
+    putStrLn "error:"
+    putStrLn s    
+    c_exit 255
+    return undefined
+    
+    
+    
+
+
+
+--foreign import primitive exit :: Int -> World__ -> IOResult ()
+foreign import ccall "exit" c_exit :: Int -> IO ()
+
+{-# INLINE seq #-}
+
+foreign import primitive seq :: a -> b -> b
+
+
+instance Enum Int where
+    succ = (+ 1)
+    pred = (+ -1)
+    toEnum x = x
+    fromEnum x = x
+
+    enumFrom x       =  x:enumFrom (x + 1)
+    enumFromTo x y = f x where
+        f x | x > y = []
+            | otherwise = x:f (x + 1)
+    enumFromThen x y = f x where
+        z = y - x
+        f x = x:f (x + z)
+    enumFromThenTo x y z = f x where
+        inc = y - x
+        f x | x <= z = x:f (x + z)
+            | otherwise = []
+    
+instance Enum Char where
+    toEnum = Char.chr
+    fromEnum = Char.ord
+
+
+instance Enum Integer where
+    toEnum = fromInt
+    fromEnum = toInt
+    succ = (+ 1)
+    pred = (+ -1)
+    enumFrom x  =  x:enumFrom (x + 1)
+    enumFromTo x y = f x where
+        f x | x > y = []
+            | otherwise = x:f (x + 1)
+    enumFromThen x y = f x where
+        z = y - x
+        f x = x:f (x + z)
+    enumFromThenTo x y z = f x where
+        inc = y - x
+        f x | x <= z = x:f (x + z)
+            | otherwise = []
+    
+
+{-
+instance (Ord a, Ord b) => Ord (a,b) where
+    compare (x,y) (a,b) = case compare x a of 
+        EQ -> compare y b
+        z -> z
+    -}
+
+instance Ord a => Ord [a] where
+    compare (x:xs) (y:ys) = case compare x y of
+        EQ -> compare xs ys
+        z -> z
+    compare [] [] = EQ
+    compare [] _ = LT
+    compare _ [] = GT
+
+instance Eq a => Eq [a] where
+    [] == [] = True
+    (x:xs) == (y:ys) | x == y = xs == ys
+    _ == _ = False
+
+uncurry f (x,y) = f x y
+curry f x y = f (x,y)
+
+{-
+instance (Eq a, Eq b) => Eq (a,b) where
+    (x,y) == (a,b) = x == a && y == b
+    -}
+    
+instance Real Integer where
+    toRational = fromInteger
+instance Real Int where
+    toRational = fromInt
+
+
+default(Int,Double)
addfile ./lib/Random.hs
hunk ./lib/Random.hs 1
+{-
+The June 1988 (v31 #6) issue of the Communications of the ACM has an
+article by Pierre L'Ecuyer called, "Efficient and Portable Combined
+Random Number Generators".  Here is the Portable Combined Generator of
+L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
+
+Transliterator: Lennart Augustsson
+
+sof 1/99 - code brought (kicking and screaming) into the new Random
+world..
+
+malcolm 2/00 - patched for nhc98
+-}
+
+module Random
+	(
+	  RandomGen(next, split, genRange)
+	, StdGen
+	, mkStdGen
+	, Random ( random,   randomR,
+		   randoms,  randomRs,
+		   randomIO, randomRIO )
+	, getStdRandom
+	, getStdGen
+	, setStdGen
+	, newStdGen
+	) where
+
+import Char ( isSpace, chr, ord )
+
+import Numeric
+import Foreign.Storable
+import Foreign.Ptr
+
+
+
+class RandomGen g where
+    next  :: g -> (Int, g)
+    split :: g -> (g, g)
+    genRange :: g -> (Int,Int)
+    genRange g = (minBound,maxBound)
+
+data StdGen = StdGen Int Int
+
+instance RandomGen StdGen where
+  next  = stdNext
+  split = stdSplit
+  genRange g = (minBound,maxBound)
+  -- without this Hat+nhc98 do not work
+
+instance Show StdGen where
+  showsPrec p (StdGen s1 s2) = 
+     showsPrec p s1 . 
+     showChar ' ' .
+     showsPrec p s2
+
+instance Read StdGen where
+  readsPrec _p = \ r ->
+     case try_read r of
+       r@[_] -> r
+       _   -> [stdFromString r] -- because it shouldn't ever fail.
+    where 
+      try_read r = do
+         (s1, r1) <- readDec (dropWhile isSpace r)
+	 (s2, r2) <- readDec (dropWhile isSpace r1)
+	 return (StdGen s1 s2, r2)
+
+{-
+ If we cannot unravel the StdGen from a string, create
+ one based on the string given.
+-}
+stdFromString         :: String -> (StdGen, String)
+stdFromString s        = (mkStdGen num, rest)
+	where (cs, rest) = splitAt 6 s
+              num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)
+
+
+mkStdGen :: Int -> StdGen -- why not Integer ?
+mkStdGen s
+ | s < 0     = mkStdGen (-s)
+ | otherwise = StdGen (s1+1) (s2+1)
+      where
+	(q, s1) = s `divMod` 2147483562
+	s2      = q `mod` 2147483398
+
+createStdGen :: Integer -> StdGen
+createStdGen s
+ | s < 0     = createStdGen (-s)
+ | otherwise = StdGen (toInt (s1+1)) (toInt (s2+1))
+      where
+	(q, s1) = s `divMod` 2147483562
+	s2      = q `mod` 2147483398
+
+
+
+class Random a where
+  -- Minimal complete definition: random and randomR
+  random  :: RandomGen g => g -> (a, g)
+  randomR :: RandomGen g => (a,a) -> g -> (a,g)
+  randoms  :: RandomGen g => g -> [a]
+  randomRs :: RandomGen g => (a,a) -> g -> [a]
+  randomIO  :: IO a
+  randomRIO :: (a,a) -> IO a
+
+  randomRs ival g = x : randomRs ival g' where 
+    (x,g') = randomR ival g
+  randomIO	   = getStdRandom random
+  randoms  g      = (\(x,g') -> x : randoms g') (random g)
+  randomRIO range  = getStdRandom (randomR range)
+
+instance Random Int where
+  randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
+  random g        = randomR (minBound,maxBound) g
+
+instance Random Char where
+  randomR (a,b) g = 
+      case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
+        (x,g) -> (chr x, g)
+  random g	  = randomR (minBound,maxBound) g
+
+instance Random Bool where
+  randomR (a,b) g = 
+      case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
+        (x, g) -> (int2Bool (x::Int), g)
+       where
+         bool2Int False = (0::Int)
+         bool2Int True  = 1
+
+	 int2Bool 0	= False
+	 int2Bool _	= True
+
+  random g	  = randomR (minBound,maxBound) g
+ 
+instance Random Integer where
+  randomR ival g = randomIvalInteger ival g
+  random g	 = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g
+
+instance Random Double where
+  randomR ival g = randomIvalDouble ival id g
+  random g       = randomR (0::Double,1) g
+  
+-- hah, so you thought you were saving cycles by using Float?
+
+instance Random Float where
+  random g        = randomIvalDouble (0::Double,1) realToFrac g
+  randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
+
+
+
+mkStdRNG :: Integer -> IO StdGen
+mkStdRNG o = return (createStdGen o)
+--mkStdRNG :: Integer -> IO StdGen
+--mkStdRNG o = do
+--    ct          <- getCPUTime
+--    (TOD sec _) <- getClockTime
+--    return (createStdGen (sec * 12345 + ct + o))
+
+randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
+randomIvalInteger (l,h) rng
+ | l > h     = randomIvalInteger (h,l) rng
+ | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
+     where
+       k = h - l + 1
+       b = 2147483561
+       --b = 2147  -- TODO Bad!
+       n = iLogBase b k
+
+       f 0 acc g = (acc, g)
+       f n acc g = 
+          let
+	   (x,g')   = next g
+	  in
+	  f (n-1) (fromInt x + acc * b) g'
+
+randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
+randomIvalDouble (l,h) fromDouble rng 
+  | l > h     = randomIvalDouble (h,l) fromDouble rng
+  | otherwise = 
+       case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
+         (x, rng') -> 
+	    let
+	     scaled_x = 
+		fromDouble ((l+h)/2) + 
+                fromDouble ((h-l) / realToFrac intRange) *
+		fromIntegral (x::Int)
+	    in
+	    (scaled_x, rng')
+
+intRange :: Integer
+intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)
+
+iLogBase :: Integer -> Integer -> Integer
+iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
+
+stdNext :: StdGen -> (Int, StdGen)
+stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
+	where	z'   = if z < 1 then z + 2147483562 else z
+		z    = s1'' - s2''
+
+		k    = s1 `quot` 53668
+		s1'  = 40014 * (s1 - k * 53668) - k * 12211
+		s1'' = if s1' < 0 then s1' + 2147483563 else s1'
+    
+		k'   = s2 `quot` 52774
+		s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
+		s2'' = if s2' < 0 then s2' + 2147483399 else s2'
+
+stdSplit            :: StdGen -> (StdGen, StdGen)
+stdSplit std@(StdGen s1 s2)
+                     = (left, right)
+                       where
+                        -- no statistical foundation for this!
+                        left    = StdGen new_s1 t2
+                        right   = StdGen t1 new_s2
+
+                        new_s1 | s1 == 2147483562 = 1
+                               | otherwise        = s1 + 1
+
+                        new_s2 | s2 == 1          = 2147483398
+                               | otherwise        = s2 - 1
+
+                        StdGen t1 t2 = snd (next std)
+--  #else
+-- stdSplit :: StdGen -> (StdGen, StdGen)
+-- stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))
+--  #endif	
+
+
+--ptr_a = unsafePerformIO $ malloc 
+--ptr_b = unsadePerformIO $ malloc 
+
+--setStdGen :: StdGen -> IO ()
+--setStdGen sgen = writeIORef theStdGen sgen
+
+--getStdGen :: IO StdGen
+--getStdGen  = readIORef theStdGen
+
+--theStdGen :: IORef StdGen
+--theStdGen  = unsafePerformIO (newIORef (createStdGen 0))
+
+setStdGen :: StdGen -> IO ()
+getStdGen :: IO StdGen
+setStdGen (StdGen a b) = do
+    pokeElemOff c_stdrnd 0 a
+    pokeElemOff c_stdrnd 1 b
+getStdGen = do
+    a <- peekElemOff c_stdrnd 0
+    b <- peekElemOff c_stdrnd 1
+    return $ StdGen a b
+
+
+foreign import ccall "&jhc_stdrnd" c_stdrnd :: Ptr Int
+
+
+newStdGen :: IO StdGen
+newStdGen = do
+  rng <- getStdGen
+  let (a,b) = split rng
+  setStdGen a
+  return b
+
+getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
+getStdRandom f = do
+   rng		<- getStdGen
+   let (v, new_rng) = f rng
+   setStdGen new_rng
+   return v
+
addfile ./lib/Ratio.hs
hunk ./lib/Ratio.hs 1
+-- Standard functions on rational numbers
+
+module  Ratio (
+    Ratio, Rational, (%), numerator, denominator, approxRational ) where
+
+import Prelude.Text
+
+infixl 7  %
+
+ratPrec = 7 :: Int
+
+data  (Integral a)      => Ratio a = !a :% !a  
+type  Rational          =  Ratio Integer
+
+(%)                     :: (Integral a) => a -> a -> Ratio a
+numerator, denominator  :: (Integral a) => Ratio a -> a
+approxRational          :: (RealFrac a) => a -> a -> Rational
+
+
+
+x % y                   =  reduce (x * signum y) (abs y)
+
+numerator (x :% _)      =  x
+
+denominator (_ :% y)    =  y
+
+
+
+
+-- "reduce" is a subsidiary function used only in this module.
+-- It normalises a ratio by dividing both numerator
+-- and denominator by their greatest common divisor.
+--
+-- E.g., 12 `reduce` 8    ==  3 :%   2
+--       12 `reduce` (-8) ==  3 :% (-2)
+
+reduce _ 0              =  error "Ratio.% : zero denominator"
+reduce x y              =  (x `quot` d) :% (y `quot` d)
+                           where d = gcd x y
+
+instance  (Integral a)  => Eq (Ratio a)  where
+    (x:%y) == (x':%y')  =  x == x' && y == y' 
+
+instance  (Integral a)  => Ord (Ratio a)  where
+    (x:%y) <= (x':%y')  =  x * y' <= x' * y
+    (x:%y) <  (x':%y')  =  x * y' <  x' * y
+    
+--negateRatio (x:%y)       =  (-x) :% y
+--(x:%y) `plusRatio` (x':%y')   =  reduce ((x*y') + (x'*y)) (y*y')
+--absRatio (x:%y)          =  abs x :% y
+
+instance  (Integral a)  => Num (Ratio a)  where
+    --(+) = plusRatio
+    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')
+    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')
+    --negate x {-(x:%y)-}   =  negateRatio x -- (-x) :% y
+    negate (x:%y)       =  (-x) :% y
+    --abs (x:%y)        =  abs x :% y
+    abs (x:%y)          =  abs x :% y
+    signum (x:%y)       =  signum x :% 1
+    fromInteger x       =  fromInteger x :% 1
+
+instance  (Integral a)  => Real (Ratio a)  where
+    toRational (x:%y)   =  toInteger x :% toInteger y
+
+instance  (Integral a)  => Fractional (Ratio a)  where
+    (x:%y) / (x':%y')   =  (x*y') % (y*x')
+    recip (x:%y)        =  y % x
+    fromRational (x:%y) =  fromInteger x :% fromInteger y
+
+instance  (Integral a)  => RealFrac (Ratio a)  where
+    properFraction (x:%y) = (fromIntegral q, r:%y)
+                            where (q,r) = quotRem x y
+
+{-
+instance  (Integral a)  => Enum (Ratio a)  where
+    succ x           =  x+1
+    pred x           =  x-1
+    toEnum           =  fromIntegral
+    fromEnum         =  fromInteger . truncate	-- May overflow
+--    enumFrom         =  numericEnumFrom		-- These numericEnumXXX functions
+--    enumFromThen     =  numericEnumFromThen	-- are as defined in Prelude.hs
+--    enumFromTo       =  numericEnumFromTo	-- but not exported from it!
+--    enumFromThenTo   =  numericEnumFromThenTo
+-}
+
+instance  (Read a, Integral a)  => Read (Ratio a)  where
+    readsPrec p  =  readParen (p > ratPrec)
+                              (\r -> [(reduce (x * signum y) (abs y),u) | (x,s)   <- readsPrec (ratPrec+1) r,
+                                                ("%",t) <- lex s,
+                                                (y,u)   <- readsPrec (ratPrec+1) t ])
+
+instance  (Integral a)  => Show (Ratio a)  where
+    showsPrec p (x:%y)  =  showParen (p > ratPrec)
+                               (showsPrec (ratPrec+1) x . 
+			        showString " % " . 
+				showsPrec (ratPrec+1) y)
+
+approxRational x eps    =  simplest (x-eps) (x+eps)
+        where simplest x y | y < x      =  simplest y x
+                           | x == y     =  xr
+                           | x > 0      =  simplest' n d n' d'
+                           | y < 0      =  - simplest' (-n') d' (-n) d
+                           | otherwise  =  0 :% 1
+                                        where xr@(n:%d) = toRational x
+                                              (n':%d')  = toRational y
+
+              simplest' n d n' d'       -- assumes 0 < n%d < n'%d'
+                        | r == 0     =  q :% 1
+                        | q /= q'    =  (q+1) :% 1
+                        | otherwise  =  (q*n''+d'') :% n''
+                                     where (q,r)      =  quotRem n d
+                                           (q',r')    =  quotRem n' d'
+                                           (n'':%d'') =  simplest' d' r' d r
addfile ./lib/System.hs
hunk ./lib/System.hs 1
+module System ( 
+    ExitCode(ExitSuccess,ExitFailure),
+    getArgs, getProgName, getEnv, system, exitWith, exitFailure
+  ) where
+
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.C.Types
+
+data ExitCode = ExitSuccess | ExitFailure Int 
+            --    deriving (Eq, Ord, Read, Show)
+
+getArgs     :: IO [String]
+getProgName :: IO String
+getEnv      :: String -> IO String
+system      :: String -> IO ExitCode
+exitWith    :: ExitCode -> IO a
+exitFailure :: IO a
+
+
+--getArgs = return []
+--getProgName = return "(jhc)"
+--getEnv _ = return ""
+
+exitWith ExitSuccess = do
+    c_exit 0 
+    return undefined
+exitWith (ExitFailure n) = do
+    c_exit n 
+    return undefined
+exitFailure = exitWith $ ExitFailure 255
+
+
+
+getProgName = peek jhc_progname >>= peekCString 
+getArgs = do
+    argc <- peek jhc_argc
+    argv <- peek jhc_argv
+    let f n = peekElemOff argv n >>= peekCString 
+    mapM f [0 .. fromIntegral argc - 1]
+
+
+getEnv s = withCString s c_getenv >>= \p -> 
+    if p == nullPtr then fail ("getEnv: " ++ show s)  else peekCString p
+
+{-
+getEnv s = case lookup s theEnvironment of 
+    Just y -> return y
+    Nothing -> fail $ "getEnv: " ++ s 
+
+theEnvironment :: [(String,String)]
+theEnvironment = unsafePerformIO $ do
+    ep <- peek c_environ
+    --let f xs ptr | ptr == nullPtr = return xs
+    --    f xs ptr = do
+    --        cs <- peekCString ptr
+    --        let (x,y) = span (/= '=') cs
+    --        return ((x,drop 1 y):xs)
+    xs <- mapM peekCString $ takeWhile (/= nullPtr) (iterate (`plusPtr` sizeOf (undefined :: CString)) ep) 
+    let g xs = (x,drop 1 y) where (x,y) = span (/= '=') xs
+    return $ map g xs
+    -}
+
+system s = withCString s c_system >>= \r -> case r of
+    0 -> return ExitSuccess 
+    _ -> return $ ExitFailure (fromIntegral r)
+
+--foreign import primitive getArgs' :: World__ -> IOResult [String]
+foreign import ccall "exit" c_exit :: Int -> IO ()
+foreign import ccall "system" c_system :: CString -> IO CInt
+foreign import ccall "stdlib.h getenv" c_getenv :: Ptr CChar -> IO (Ptr CChar)
+
+foreign import ccall "&jhc_progname" jhc_progname :: Ptr CString
+foreign import ccall "&jhc_argc" jhc_argc :: Ptr CInt
+foreign import ccall "&jhc_argv" jhc_argv :: Ptr (Ptr CString)
+--foreign import ccall "&environ" c_environ :: (Ptr (Ptr CString))
addfile ./lib/System/Console.GetOpt.hs
hunk ./lib/System/Console.GetOpt.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  System.Console.GetOpt
+-- Copyright   :  (c) Sven Panne 2002-2004
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program.  It is essentially a Haskell port of the GNU 
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+  are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+  compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example! 
+:-)
+-}
+
+module System.Console.GetOpt (
+   -- * GetOpt
+   getOpt,
+   usageInfo,
+   ArgOrder(..),
+   OptDescr(..),
+   ArgDescr(..),
+
+   -- * Example
+
+   -- $example
+) where
+
+import Prelude -- necessary to get dependencies right
+
+import Data.List ( isPrefixOf )
+
+-- |What to do with options following non-options
+data ArgOrder a
+  = RequireOrder                -- ^ no option processing after first non-option
+  | Permute                     -- ^ freely intersperse options and non-options
+  | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a =              -- description of a single options:
+   Option [Char]                --    list of short option characters
+          [String]              --    list of long option strings (without "--")
+          (ArgDescr a)          --    argument descriptor
+          String                --    explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+   = NoArg                   a         -- ^   no argument expected
+   | ReqArg (String       -> a) String -- ^   option requires argument
+   | OptArg (Maybe String -> a) String -- ^   optional argument
+
+data OptKind a                -- kind of cmd line arg (internal use only):
+   = Opt       a                --    an option
+   | NonOpt    String           --    a non-option
+   | EndOfOpts                  --    end-of-options marker (i.e. "--")
+   | OptErr    String           --    something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the 
+-- second argument.
+usageInfo :: String                    -- header
+          -> [OptDescr a]              -- option descriptors
+          -> String                    -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescr
+         table          = zipWith3 paste (sameLen ss) (sameLen ls) ds
+         paste x y z    = "  " ++ x ++ "  " ++ y ++ "  " ++ z
+         sameLen xs     = flushLeft ((maximum . map length) xs) xs
+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]
+
+fmtOpt :: OptDescr a -> [(String,String,String)]
+fmtOpt (Option sos los ad descr) =
+   case lines descr of
+     []     -> [(sosFmt,losFmt,"")]
+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("","",d') | d' <- ds ]
+   where sepBy _  []     = ""
+         sepBy _  [x]    = x
+         sepBy ch (x:xs) = x ++ ch:' ':sepBy ch xs
+         sosFmt = sepBy ',' (map (fmtShort ad) sos)
+         losFmt = sepBy ',' (map (fmtLong  ad) los)
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg  _   ) so = "-" ++ [so]
+fmtShort (ReqArg _ ad) so = "-" ++ [so] ++ " " ++ ad
+fmtShort (OptArg _ ad) so = "-" ++ [so] ++ "[" ++ ad ++ "]"
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg  _   ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from 
+  'System.Environment.getArgs').
+
+'getOpt' returns a triple, consisting of the argument values, a list
+of options that didn\'t match, and a list of error messages.
+-}
+getOpt :: ArgOrder a                   -- non-option handling
+       -> [OptDescr a]                 -- option descriptors
+       -> [String]                     -- the commandline arguments
+       -> ([a],[String],[String])      -- (options,non-options,error messages)
+getOpt _        _        []         =  ([],[],[])
+getOpt ordering optDescr (arg:args) = procNextOpt opt ordering
+   where procNextOpt (Opt o)    _                 = (o:os,xs,es)
+         procNextOpt (NonOpt x) RequireOrder      = ([],x:rest,[])
+         procNextOpt (NonOpt x) Permute           = (os,x:xs,es)
+         procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,es)
+         procNextOpt EndOfOpts  RequireOrder      = ([],rest,[])
+         procNextOpt EndOfOpts  Permute           = ([],rest,[])
+         procNextOpt EndOfOpts  (ReturnInOrder f) = (map f rest,[],[])
+         procNextOpt (OptErr e) _                 = (os,xs,e:es)
+
+         (opt,rest) = getNext arg args optDescr
+         (os,xs,es) = getOpt ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _        = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
+getNext a            rest _        = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+   where (opt,arg) = break (=='=') ls
+         getWith p = [ o  | o@(Option _ ls _ _) <- optDescr, l <- ls, opt `p` l ]
+         exact     = getWith (==)
+         options   = if null exact then getWith isPrefixOf else exact
+         ads       = [ ad | Option _ _ ad _ <- options ]
+         optStr    = ("--"++opt)
+
+         long (_:_:_)      _        rest     = (errAmbig options optStr,rest)
+         long [NoArg  a  ] []       rest     = (Opt a,rest)
+         long [NoArg  _  ] ('=':_)  rest     = (errNoArg optStr,rest)
+         long [ReqArg _ d] []       []       = (errReq d optStr,[])
+         long [ReqArg f _] []       (r:rest) = (Opt (f r),rest)
+         long [ReqArg f _] ('=':xs) rest     = (Opt (f xs),rest)
+         long [OptArg f _] []       rest     = (Opt (f Nothing),rest)
+         long [OptArg f _] ('=':xs) rest     = (Opt (f (Just xs)),rest)
+         long _            _        rest     = (errUnrec optStr,rest)
+
+-- handle short option
+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+shortOpt x xs rest optDescr = short ads xs rest
+  where options = [ o  | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]
+        ads     = [ ad | Option _ _ ad _ <- options ]
+        optStr  = '-':[x]
+
+        short (_:_:_)        _  rest     = (errAmbig options optStr,rest)
+        short (NoArg  a  :_) [] rest     = (Opt a,rest)
+        short (NoArg  a  :_) xs rest     = (Opt a,('-':xs):rest)
+        short (ReqArg _ d:_) [] []       = (errReq d optStr,[])
+        short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
+        short (ReqArg f _:_) xs rest     = (Opt (f xs),rest)
+        short (OptArg f _:_) [] rest     = (Opt (f Nothing),rest)
+        short (OptArg f _:_) xs rest     = (Opt (f (Just xs)),rest)
+        short []             [] rest     = (errUnrec optStr,rest)
+        short []             xs rest     = (errUnrec optStr,('-':xs):rest)
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+   where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> OptKind a
+errUnrec optStr = OptErr ("unrecognized option `" ++ optStr ++ "'\n")
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String   deriving Show
+
+options :: [OptDescr Flag]
+options =
+   [Option ['v']     ["verbose"]           (NoArg Verbose)      "verbosely list files",
+    Option ['V','?'] ["version","release"] (NoArg Version)      "show version info",
+    Option ['o']     ["output"]            (OptArg out "FILE")  "use FILE for dump",
+    Option ['n']     ["name"]              (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing  = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+                        (o,n,[]  ) -> "options=" ++ show o ++ "  args=" ++ show n ++ "\n"
+                        (_,_,errs) -> concat errs ++ usageInfo header options
+   where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+--    ==> options=[]  args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+--    ==> options=[Verbose]  args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+--    ==> options=[Arg "foo", Verbose]  args=[]
+-- putStr (test Permute ["foo","--","-v"])
+--    ==> options=[]  args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+--    ==> options=[Version, Output "stdout", Name "bar", Name "baz"]  args=[]
+-- putStr (test Permute ["--ver","foo"])
+--    ==> option `--ver' is ambiguous; could be one of:
+--          -v      --verbose             verbosely list files
+--          -V, -?  --version, --release  show version info   
+--        Usage: foobar [OPTION...] files...
+--          -v        --verbose             verbosely list files  
+--          -V, -?    --version, --release  show version info     
+--          -o[FILE]  --output[=FILE]       use FILE for dump     
+--          -n USER   --name=USER           only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example
+
+To hopefully illuminate the role of the different data
+structures, here\'s the command-line options for a (very simple)
+compiler:
+
+>    module Opts where
+>    
+>    import System.Console.GetOpt
+>    import Data.Maybe ( fromMaybe )
+>    
+>    data Flag 
+>     = Verbose  | Version 
+>     | Input String | Output String | LibDir String
+>       deriving Show
+>    
+>    options :: [OptDescr Flag]
+>    options =
+>     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output on stderr"
+>     , Option ['V','?'] ["version"] (NoArg Version)       "show version number"
+>     , Option ['o']     ["output"]  (OptArg outp "FILE")  "output FILE"
+>     , Option ['c']     []          (OptArg inp  "FILE")  "input FILE"
+>     , Option ['L']     ["libdir"]  (ReqArg LibDir "DIR") "library directory"
+>     ]
+>    
+>    inp,outp :: Maybe String -> Flag
+>    outp = Output . fromMaybe "stdout"
+>    inp  = Input  . fromMaybe "stdout"
+>    
+>    compilerOpts :: [String] -> IO ([Flag], [String])
+>    compilerOpts argv = 
+>       case (getOpt Permute options argv) of
+>          (o,n,[]  ) -> return (o,n)
+>          (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+>      where header = "Usage: ic [OPTION...] files..."
+
+-}
addfile ./lib/System/IO.Binary.hs
hunk ./lib/System/IO.Binary.hs 1
+module System.IO.Binary(readBinaryFile) where
+
+import Data.Word
+import Jhc.IO
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Ptr
+import Foreign.C.Error
+
+-- | Lazily read a file as a sequence of bytes.
+
+readBinaryFile :: FilePath -> IO [Word8] 
+readBinaryFile fn = do
+    file <- withCString fn $ \fnc -> c_fopen fnc read_str
+    if  (file == nullPtr) then getErrno >>= \errno -> (ioError $ errnoToIOError "readBinaryFile" errno Nothing (Just fn)) else do
+        let gc = do
+                ch <- c_getc file
+                case ch of
+                    -1 -> c_fclose file >> return []
+                    _ -> do
+                        xs <- unsafeInterleaveIO gc 
+                        return (cintToWord8 ch:xs)
+        unsafeInterleaveIO gc
+
+foreign import primitive "integralCast" cintToWord8 :: CInt -> Word8
+foreign import primitive "const.\"rb\"" read_str :: Ptr CChar
+
+foreign import ccall "stdio.h getc" c_getc :: Ptr () -> IO CInt
+foreign import ccall "stdio.h fopen" c_fopen :: CString -> CString -> IO (Ptr ())
+foreign import ccall "stdio.h fclose" c_fclose :: Ptr () -> IO CInt
addfile ./lib/System/IO.Unsafe.hs
hunk ./lib/System/IO.Unsafe.hs 1
+{-# OPTIONS -N #-}
+module System.IO.Unsafe(unsafePerformIO, unsafeInterleaveIO) where
+
+import Jhc.IO
+
+
addfile ./lib/System/Info.hs
hunk ./lib/System/Info.hs 1
+module System.Info where
+
+
+compilerName = "jhc"
+compilerVersion = "0"
addfile ./lib/Test/QuickCheck.hs
hunk ./lib/Test/QuickCheck.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Test.QuickCheck
+-- Copyright   :  (c) Koen Claessen, John Hughes 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- QuickCheck v.0.2
+-- DRAFT implementation; last update 000104.
+-- Koen Claessen, John Hughes.
+-- This file represents work in progress, and might change at a later date.
+--
+-----------------------------------------------------------------------------
+
+module Test.QuickCheck
+  -- testing functions
+  ( quickCheck    -- :: prop -> IO ()
+  , verboseCheck  -- :: prop -> IO ()
+  , test          -- :: prop -> IO ()  -- = quickCheck
+  
+  , Config(Config, configMaxTest, configMaxFail, configSize, configEvery)    -- :: *
+  , defaultConfig -- :: Config
+  , check         -- :: Config -> prop -> IO ()
+ 
+  -- property combinators
+  , forAll        -- :: Gen a -> (a -> prop) -> prop
+  , (==>)         -- :: Bool -> prop -> prop
+  
+  -- gathering test-case information
+  , label         -- :: String         -> prop -> prop
+  , collect       -- :: Show a => a    -> prop -> prop
+  , classify      -- :: Bool -> String -> prop -> prop
+  , trivial       -- :: Bool           -> prop -> prop
+  
+  -- generator combinators
+  , Gen           -- :: * -> * ; Functor, Monad
+  
+  , elements      -- :: [a] -> Gen a
+  , two           -- :: Gen a -> Gen (a,a)
+  , three         -- :: Gen a -> Gen (a,a,a)
+  , four          -- :: Gen a -> Gen (a,a,a,a)
+  
+  , sized         -- :: (Int -> Gen a) -> Gen a
+  , resize        -- :: Int -> Gen a -> Gen a
+  , choose        -- :: Random a => (a, a) -> Gen a
+  , oneof         -- :: [Gen a] -> Gen a
+  , frequency     -- :: [(Int, Gen a)] -> Gen a
+  
+  , vector        -- :: Arbitrary a => Int -> Gen [a]
+
+  -- default generators
+  , Arbitrary(arbitrary,coarbitrary) -- :: class
+  , rand          -- :: Gen StdGen
+  , promote       -- :: (a -> Gen b) -> Gen (a -> b)
+  , variant       -- :: Int -> Gen a -> Gen a
+
+  -- testable
+  , Testable(property)  -- :: class
+  , Property      -- :: *
+
+  -- For writing your own driver
+  , Result(Result,ok,arguments)	 -- :: data
+  , generate	 -- :: Int -> StdGen -> Gen a -> a
+  , evaluate     -- :: Testable a => a -> Gen Result
+  )
+ where
+
+import Prelude
+
+import Random
+import List( group, sort, intersperse )
+import Monad( liftM2, liftM3, liftM4 )
+
+infixr 0 ==>
+infix  1 `classify`
+
+--------------------------------------------------------------------
+-- Generator
+
+newtype Gen a
+  = Gen (Int -> StdGen -> a)
+
+sized :: (Int -> Gen a) -> Gen a
+sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)
+
+resize :: Int -> Gen a -> Gen a
+resize n (Gen m) = Gen (\_ r -> m n r)
+
+rand :: Gen StdGen
+rand = Gen (\n r -> r)
+
+promote :: (a -> Gen b) -> Gen (a -> b)
+promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)
+
+variant :: Int -> Gen a -> Gen a
+variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
+ where
+  rands r0 = r1 : rands r2 where (r1, r2) = split r0
+
+generate :: Int -> StdGen -> Gen a -> a
+generate n rnd (Gen m) = m size rnd'
+ where
+  (size, rnd') = randomR (0, n) rnd
+
+instance Functor Gen where
+  fmap f m = m >>= return . f
+
+instance Monad Gen where
+  return a    = Gen (\n r -> a)
+  Gen m >>= k =
+    Gen (\n r0 -> let (r1,r2) = split r0
+                      Gen m'  = k (m n r1)
+                   in m' n r2)
+
+-- derived
+
+choose :: Random a => (a, a) -> Gen a
+choose bounds = (fst . randomR bounds) `fmap` rand
+
+elements :: [a] -> Gen a
+elements xs = (xs !!) `fmap` choose (0, length xs - 1)
+
+vector :: Arbitrary a => Int -> Gen [a]
+vector n = sequence [ arbitrary | i <- [1..n] ]
+
+oneof :: [Gen a] -> Gen a
+oneof gens = elements gens >>= id
+
+frequency :: [(Int, Gen a)] -> Gen a
+frequency xs = choose (1, tot) >>= (`pick` xs)
+ where
+  tot = sum (map fst xs)
+
+  pick n ((k,x):xs)
+    | n <= k    = x
+    | otherwise = pick (n-k) xs
+
+-- general monadic
+
+two :: Monad m => m a -> m (a, a)
+two m = liftM2 (,) m m
+
+three :: Monad m => m a -> m (a, a, a)
+three m = liftM3 (,,) m m m
+
+four :: Monad m => m a -> m (a, a, a, a)
+four m = liftM4 (,,,) m m m m
+
+--------------------------------------------------------------------
+-- Arbitrary
+
+class Arbitrary a where
+  arbitrary   :: Gen a
+  coarbitrary :: a -> Gen b -> Gen b
+
+instance Arbitrary () where
+  arbitrary     = return ()
+  coarbitrary _ = variant 0
+
+instance Arbitrary Bool where
+  arbitrary     = elements [True, False]
+  coarbitrary b = if b then variant 0 else variant 1
+
+instance Arbitrary Int where
+  arbitrary     = sized $ \n -> choose (-n,n)
+  coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)
+
+instance Arbitrary Integer where
+  arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
+  coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))
+
+instance Arbitrary Float where
+  arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary 
+  coarbitrary x = coarbitrary (decodeFloat x)
+
+instance Arbitrary Double where
+  arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary 
+  coarbitrary x = coarbitrary (decodeFloat x)
+
+fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
+  arbitrary          = liftM2 (,) arbitrary arbitrary
+  coarbitrary (a, b) = coarbitrary a . coarbitrary b
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
+  arbitrary             = liftM3 (,,) arbitrary arbitrary arbitrary
+  coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c
+
+instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
+      => Arbitrary (a, b, c, d)
+ where
+  arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
+  coarbitrary (a, b, c, d) =
+    coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d
+
+instance Arbitrary a => Arbitrary [a] where
+  arbitrary          = sized (\n -> choose (0,n) >>= vector)
+  coarbitrary []     = variant 0
+  coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
+  arbitrary         = promote (`coarbitrary` arbitrary)
+  coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)
+
+--------------------------------------------------------------------
+-- Testable
+
+data Result
+  = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }
+
+nothing :: Result
+nothing = Result{ ok = Nothing, stamp = [], arguments = [] }
+
+newtype Property
+  = Prop (Gen Result)
+
+result :: Result -> Property
+result res = Prop (return res)
+
+evaluate :: Testable a => a -> Gen Result
+evaluate a = gen where Prop gen = property a
+
+class Testable a where
+  property :: a -> Property
+
+instance Testable () where
+  property _ = result nothing
+
+instance Testable Bool where
+  property b = result (nothing{ ok = Just b })
+
+instance Testable Result where
+  property res = result res
+
+instance Testable Property where
+  property prop = prop
+
+instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
+  property f = forAll arbitrary f
+
+forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
+forAll gen body = Prop $
+  do a   <- gen
+     res <- evaluate (body a)
+     return (argument a res)
+ where
+  argument a res = res{ arguments = show a : arguments res }
+
+(==>) :: Testable a => Bool -> a -> Property
+True  ==> a = property a
+False ==> a = property ()
+
+label :: Testable a => String -> a -> Property
+label s a = Prop (add `fmap` evaluate a)
+ where
+  add res = res{ stamp = s : stamp res }
+
+classify :: Testable a => Bool -> String -> a -> Property
+classify True  name = label name
+classify False _    = property
+
+trivial :: Testable a => Bool -> a -> Property
+trivial = (`classify` "trivial")
+
+collect :: (Show a, Testable b) => a -> b -> Property
+collect v = label (show v)
+
+--------------------------------------------------------------------
+-- Testing
+
+data Config = Config
+  { configMaxTest :: Int
+  , configMaxFail :: Int
+  , configSize    :: Int -> Int
+  , configEvery   :: Int -> [String] -> String
+  }
+
+quick :: Config
+quick = Config
+  { configMaxTest = 100
+  , configMaxFail = 1000
+  , configSize    = (+ 3) . (`div` 2)
+  , configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
+  }
+         
+verbose :: Config
+verbose = quick
+  { configEvery = \n args -> show n ++ ":\n" ++ unlines args
+  }
+
+defaultConfig :: Config
+defaultConfig = quick
+
+test, quickCheck, verboseCheck :: Testable a => a -> IO ()
+test         = check quick
+quickCheck   = check quick
+verboseCheck = check verbose
+         
+check :: Testable a => Config -> a -> IO ()
+check config a =
+  do rnd <- newStdGen
+     tests config (evaluate a) rnd 0 0 []
+
+tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () 
+tests config gen rnd0 ntest nfail stamps
+  | ntest == configMaxTest config = do done "OK, passed" ntest stamps
+  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
+  | otherwise               =
+      do putStr (configEvery config ntest (arguments result))
+         case ok result of
+           Nothing    ->
+             tests config gen rnd1 ntest (nfail+1) stamps
+           Just True  ->
+             tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
+           Just False ->
+             putStr ( "Falsifiable, after "
+                   ++ show ntest
+                   ++ " tests:\n"
+                   ++ unlines (arguments result)
+                    )
+     where
+      result      = generate (configSize config ntest) rnd2 gen
+      (rnd1,rnd2) = split rnd0
+
+done :: String -> Int -> [[String]] -> IO ()
+done mesg ntest stamps =
+  do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
+ where
+  table = display
+        . map entry
+        . reverse
+        . sort
+        . map pairLength
+        . group
+        . sort
+        . filter (not . null)
+        $ stamps
+
+  display []  = ".\n"
+  display [x] = " (" ++ x ++ ").\n"
+  display xs  = ".\n" ++ unlines (map (++ ".") xs)
+
+  pairLength xss@(xs:_) = (length xss, xs)
+  entry (n, xs)         = percentage n ntest
+                       ++ " "
+                       ++ concat (intersperse ", " xs)
+
+  percentage n m        = show ((100 * n) `div` m) ++ "%"
+
+--------------------------------------------------------------------
+-- the end.
addfile ./lib/Test/QuickCheck/Batch.hs
hunk ./lib/Test/QuickCheck/Batch.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Test.QuickCheck.Batch
+-- Copyright   :  (c) Andy Gill 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  non-portable (uses Control.Exception, Control.Concurrent)
+--
+-- This is a batch driver for running QuickCheck (GHC only).
+--
+-----------------------------------------------------------------------------
+
+{-
+ - Here is the key for reading the output.
+ -  . = test successful
+ -  ? = every example passed, but quickcheck did not find enough good examples
+ -  * = test aborted for some reason (out-of-time, bottom, etc)
+ -  # = test failed outright
+ - 
+ - We also provide the dangerous "isBottom".
+ -
+ - Here is is an example of use for sorting:
+ - 
+ - testOptions :: TestOptions
+ - testOptions = TestOptions 
+ -                 { no_of_tests = 100		-- number of tests to run
+ -                 , length_of_tests = 1	-- 1 second max per check
+ -						-- where a check == n tests
+ -                 , debug_tests = False	-- True => debugging info
+ -                 }
+ - 
+ - prop_sort1 xs = sort xs == sortBy compare xs
+ -   where types = (xs :: [OrdALPHA])
+ - prop_sort2 xs = 
+ -         (not (null xs)) ==>
+ -         (head (sort xs) == minimum xs)
+ -   where types = (xs :: [OrdALPHA])
+ - prop_sort3 xs = (not (null xs)) ==>
+ -         last (sort xs) == maximum xs
+ -   where types = (xs :: [OrdALPHA])
+ - prop_sort4 xs ys =
+ -         (not (null xs)) ==>
+ -         (not (null ys)) ==>
+ -         (head (sort (xs ++ ys)) == min (minimum xs) (minimum ys))
+ -   where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
+ - prop_sort6 xs ys =
+ -         (not (null xs)) ==>
+ -         (not (null ys)) ==>
+ -         (last (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
+ -   where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
+ - prop_sort5 xs ys =
+ -         (not (null xs)) ==>
+ -         (not (null ys)) ==>
+ -         (head (sort (xs ++ ys)) == max (maximum xs) (maximum ys))
+ -   where types = (xs :: [OrdALPHA], ys :: [OrdALPHA])
+ - 
+ - test_sort = runTests "sort" testOptions
+ -         [ run prop_sort1
+ -         , run prop_sort2
+ -         , run prop_sort3
+ -         , run prop_sort4
+ -         , run prop_sort5
+ -         ]
+ - 
+ - When run, this gives
+ - Main> test_sort
+ -                     sort : .....
+ - 
+ - You would tie together all the test_* functions
+ - into one test_everything, on a per module basis.
+ -
+ - Examples of use of bottom and isBottom:
+ -      {- test for abort -}
+ -	prop_head2 = isBottom (head [])
+ -      {- test for strictness -}
+ -	prop_head3 = isBottom (head bottom)
+ -}
+
+module Test.QuickCheck.Batch
+   ( run		-- :: Testable a => a -> TestOptions -> IO TestResult
+   , runTests		-- :: String -> TestOptions -> 
+			--	[TestOptions -> IO TestResult] -> IO ()
+   , defOpt		-- :: TestOptions
+   , TestOptions (..)
+   , TestResult (..)
+   , isBottom		-- :: a -> Bool
+   , bottom		-- :: a 		{- _|_ -}
+   ) where
+
+import Prelude
+
+import System.Random
+import Control.Concurrent
+import Control.Exception hiding (catch, evaluate)
+import qualified Control.Exception as Exception (catch, evaluate)
+import Test.QuickCheck
+import System.IO.Unsafe
+
+data TestOptions = TestOptions {
+	no_of_tests     :: Int,
+	length_of_tests :: Int,
+	debug_tests     :: Bool }
+
+defOpt :: TestOptions
+defOpt = TestOptions 
+	{ no_of_tests = 100
+	, length_of_tests = 1
+	, debug_tests = False
+	}
+
+data TestResult = TestOk 	String  Int [[String]]
+		| TestExausted 	String  Int [[String]]
+		| TestFailed   [String] Int
+		| TestAborted   Exception
+
+tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] 
+      -> IO TestResult
+tests config gen rnd0 ntest nfail stamps
+  | ntest == configMaxTest config = return (TestOk  "OK, passed" ntest stamps)
+  | nfail == configMaxFail config = return (TestExausted "Arguments exhausted after"
+					 ntest stamps)
+  | otherwise               =
+      do (if not (null txt) then putStr txt else return ())
+	 case ok result of
+           Nothing    ->
+             tests config gen rnd1 ntest (nfail+1) stamps
+           Just True  ->
+             tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
+           Just False ->
+             do return (TestFailed (arguments result) ntest)
+     where
+      txt         = configEvery config ntest (arguments result)
+      result      = generate (configSize config ntest) rnd2 gen
+      (rnd1,rnd2) = split rnd0
+
+batch n v = Config
+  { configMaxTest = n
+  , configMaxFail = n * 10
+  , configSize    = (+ 3) . (`div` 2)
+  , configEvery   = \n args -> if v then show n ++ ":\n" ++ unlines args else ""
+  }
+
+-- Here we use the same random number each time,
+-- so we get reproducable results!
+run :: Testable a => a -> TestOptions -> IO TestResult
+run a TestOptions { no_of_tests = n, length_of_tests = len, debug_tests = debug } =
+  do me <- myThreadId
+     ready <- newEmptyMVar
+     r <- if len == 0
+	   then try theTest
+	   else try (do
+     	     -- This waits a bit, then raises an exception in its parent,
+             -- saying, right, you've had long enough!
+	     watcher <- forkIO (Exception.catch
+			      (do threadDelay (len * 1000 * 1000)
+				  takeMVar ready
+				  throwTo me NonTermination
+				  return ())
+			      (\ _ -> return ()))
+	     -- Tell the watcher we are starting...
+	     putMVar ready ()
+             -- This is cheating, because possibly some of the internal message
+             -- inside "r" might be _|_, but anyway....
+	     r <- theTest
+	     -- Now, we turn off the watcher.
+	     -- Ignored if the watcher is already dead,	
+	     -- (unless some unlucky thread picks up the same name)
+	     killThread watcher
+	     return r)
+     case r of
+        Right r -> return r
+        Left  e -> return (TestAborted e)
+  where
+	theTest = tests (batch n debug) (evaluate a) (mkStdGen 0) 0 0 []     
+
+-- Prints a one line summary of various tests with common theme
+runTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ()
+runTests name scale actions =
+  do putStr (rjustify 25 name ++ " : ")
+     f <- tr 1 actions [] 0
+     mapM fa f
+     return ()
+  where
+	rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
+
+	tr n [] xs c = do
+			putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
+			return xs
+	tr n (action:actions) others c = 
+	   do r <- action scale
+	      case r of
+		(TestOk _ m _) 
+			-> do { putStr "." ;
+			       tr (n+1) actions others (c+m) }
+		(TestExausted s m ss) 
+
+			-> do { putStr "?" ;
+			       tr (n+1) actions others (c+m) }
+		(TestAborted e) 
+			-> do { putStr "*" ;
+			       tr (n+1) actions others c }
+	  	(TestFailed f num)
+			-> do { putStr "#" ;
+			        tr (n+1) actions ((f,n,num):others) (c+num) }
+
+	fa :: ([String],Int,Int) -> IO ()
+	fa (f,n,no) = 
+	  do putStr "\n"
+	     putStr ("    ** test " 
+			++ show (n  :: Int)
+			++ " of "
+			++ name
+			++ " failed with the binding(s)\n")
+	     sequence_ [putStr ("    **   " ++ v ++ "\n")
+			| v <- f ]
+  	     putStr "\n"
+
+-- Look out behind you! These can be misused badly.
+-- However, in the context of a batch tester, can also be very useful.
+
+bottom :: a
+bottom = error "_|_"
+
+isBottom :: a -> Bool
+isBottom a = unsafePerformIO (do
+	a' <- try (Exception.evaluate a)
+	case a' of
+	   Left _ -> return True
+	   Right _ -> return False)
addfile ./lib/Test/QuickCheck/Poly.hs
hunk ./lib/Test/QuickCheck/Poly.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Test.QuickCheck.Poly
+-- Copyright   :  (c) Andy Gill 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- This is an attempt to emulate polymorphic types for the 
+-- purposes of testing by using abstract monomorphic types.
+-- 
+-- It is likely that future versions of QuickCheck will
+-- include some polymorphic emulation testing facility,
+-- but this module can be used for now.
+--
+-----------------------------------------------------------------------------
+
+module Test.QuickCheck.Poly
+  ( ALPHA
+  , BETA
+  , GAMMA
+  , OrdALPHA
+  , OrdBETA
+  , OrdGAMMA
+  ) where
+
+import Prelude
+
+import Test.QuickCheck
+import Test.QuickCheck.Utils
+
+{- This is the basic pseudo-polymorphic object.
+ - The idea is you can't cheat, and use the integer
+ - directly, but need to use the abstraction.
+ - 
+ - We use phantom types (ref: Domain Specific Embedded Compilers,
+ - Daan Leijen & Erik Meijer, 2nd Conference of Domain Specific
+ - Languages, Austin, TX, 1999)
+ -}
+
+newtype Poly a = Poly Int
+
+instance Show (Poly a) where
+        show (Poly a) = "_" ++ show a
+
+instance Arbitrary (Poly a) where
+    arbitrary            = sized $ \n -> (choose (1,n) >>= return . Poly)
+    coarbitrary (Poly n) = variant (if n >= 0 then 2*n else 2*(-n) + 1)
+
+instance Eq a => Eq (Poly a) where
+        (Poly a) == (Poly b) = a == b
+
+instance Ord a => Ord (Poly a) where
+        (Poly a) `compare` (Poly b) = a `compare` b
+
+{-
+ - These are what we export, our pseudo-polymorphic instances.
+ -}
+
+type ALPHA = Poly ALPHA_
+data ALPHA_ = ALPHA_ deriving (Eq)
+
+type BETA = Poly BETA_
+data BETA_ = BETA_ deriving (Eq)
+
+type GAMMA = Poly GAMMA_
+data GAMMA_ = GAMMA_ deriving (Eq)
+
+type OrdALPHA = Poly OrdALPHA_
+data OrdALPHA_ = OrdALPHA_ deriving (Eq,Ord)
+
+type OrdBETA = Poly OrdBETA_
+data OrdBETA_ = OrdBETA_ deriving (Eq,Ord)
+
+type OrdGAMMA = Poly OrdGAMMA_
+data OrdGAMMA_ = OrdGAMMA_ deriving (Eq,Ord)
+
+{-
+ - This is a condition on OrdALPHA, OrdBETA, etc, itself.
+ - It states that all OrdALPHA objects obey total ordering.
+ -}
+
+prop_OrdPOLY x y = isTotalOrder x y
+    where types = (x :: OrdALPHA, y :: OrdALPHA)
addfile ./lib/Test/QuickCheck/Utils.hs
hunk ./lib/Test/QuickCheck/Utils.hs 1
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Test.QuickCheck.Utils
+-- Copyright   :  (c) Andy Gill 2001
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  experimental
+-- Portability :  portable
+--
+-- These are some general purpose utilities for use with QuickCheck.
+--
+-----------------------------------------------------------------------------
+
+module Test.QuickCheck.Utils
+  ( isAssociativeBy
+  , isAssociative
+  , isCommutableBy
+  , isCommutable
+  , isTotalOrder
+  ) where
+
+import Prelude
+
+import Test.QuickCheck
+
+isAssociativeBy :: (Show a,Testable prop) 
+		=> (a -> a -> prop) -> Gen a -> (a -> a -> a) -> Property
+isAssociativeBy (===) src (**) = 
+     	forAll src $ \ a ->
+     	forAll src $ \ b ->
+     	forAll src $ \ c ->
+	((a ** b) ** c) === (a ** (b ** c))
+
+isAssociative :: (Arbitrary a,Show a,Eq a) => (a -> a -> a) -> Property
+isAssociative = isAssociativeBy (==) arbitrary
+
+isCommutableBy :: (Show a,Testable prop) 
+	       => (b -> b -> prop) -> Gen a -> (a -> a -> b) -> Property
+isCommutableBy (===) src (**) =
+	forAll src $ \ a ->
+	forAll src $ \ b ->
+	(a ** b) === (b ** a)
+
+isCommutable :: (Arbitrary a,Show a,Eq b) => (a -> a -> b) -> Property
+isCommutable = isCommutableBy (==) arbitrary
+
+isTotalOrder :: (Arbitrary a,Show a,Ord a) => a -> a -> Property
+isTotalOrder x y = 
+    classify (x > y)  "less than" $
+    classify (x == y) "equals" $
+    classify (x < y)  "greater than" $
+    x < y || x == y || x > y
addfile ./lib/Text/Show/Functions.hs
hunk ./lib/Text/Show/Functions.hs 1
+module Text.Show.Functions where
+
+
+instance Show (a -> b) where
+    showsPrec _ _ = showString "<function>"
addfile ./lib/Time.hs
hunk ./lib/Time.hs 1
+module Time (
+    ClockTime, 
+    Month(..),
+    Day(..),
+    CalendarTime(..),
+    TimeDiff(..),
+    getClockTime, 
+    addToClockTime, 
+    diffClockTimes,
+    toCalendarTime, 
+    toUTCTime, 
+    toClockTime,
+    calendarTimeToString, 
+    formatCalendarTime 
+    ) where
+
+import Ix(Ix)
+
+data ClockTime = ClockTime Int -- Implementation-dependent
+--instance Ord  ClockTime where ...
+--instance Eq   ClockTime where ...
+
+data Month =  January   | February | March    | April
+           |  May       | June     | July     | August
+           |  September | October  | November | December
+           deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
+
+data Day   =  Sunday | Monday  | Tuesday  | Wednesday | Thursday 
+           |  Friday | Saturday
+           deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show)
+
+data CalendarTime = CalendarTime {
+    ctYear   :: Int,
+    ctMonth  :: Month,
+    ctDay, ctHour, ctMin, ctSec  :: Int,
+    ctPicosec :: Integer,
+    ctWDay    :: Day,
+    ctYDay       :: Int,
+    ctTZName   :: String,
+    ctTZ          :: Int,
+    ctIsDST :: Bool
+    } deriving (Eq, Ord, Read, Show)
+
+data TimeDiff = TimeDiff {
+    tdYear, tdMonth, tdDay, tdHour, tdMin, tdSec :: Int,
+    tdPicosec      :: Integer
+    } deriving (Eq, Ord, Read, Show)
+
+
+-- Functions on times
+getClockTime         :: IO ClockTime
+     
+addToClockTime       :: TimeDiff  -> ClockTime -> ClockTime
+diffClockTimes       :: ClockTime -> ClockTime -> TimeDiff
+     
+toCalendarTime       :: ClockTime    -> IO CalendarTime
+toUTCTime            :: ClockTime    -> CalendarTime
+toClockTime          :: CalendarTime -> ClockTime
+calendarTimeToString :: CalendarTime -> String
+formatCalendarTime   :: TimeLocale -> String -> CalendarTime -> String
+
+calendarTimeToString    :: CalendarTime -> String
+calendarTimeToString    =  formatCalendarTime defaultTimeLocale "%c"
+
+formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String
+formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec 
+                                           wday yday tzname _ _) =
+        doFmt fmt
+  where doFmt ('%':c:cs) = decode c ++ doFmt cs
+        doFmt (c:cs) = c : doFmt cs
+        doFmt "" = ""
+
+        to12 :: Int -> Int
+        to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h'
+
+        decode 'A' = fst (wDays l  !! fromEnum wday)
+        decode 'a' = snd (wDays l  !! fromEnum wday)
+        decode 'B' = fst (months l !! fromEnum mon)
+        decode 'b' = snd (months l !! fromEnum mon)
+        decode 'h' = snd (months l !! fromEnum mon)
+        decode 'C' = show2 (year `quot` 100)
+        decode 'c' = doFmt (dateTimeFmt l)
+        decode 'D' = doFmt "%m/%d/%y"
+        decode 'd' = show2 day
+        decode 'e' = show2' day
+        decode 'H' = show2 hour
+        decode 'I' = show2 (to12 hour)
+        decode 'j' = show3 yday
+        decode 'k' = show2' hour
+        decode 'l' = show2' (to12 hour)
+        decode 'M' = show2 min
+        decode 'm' = show2 (fromEnum mon+1)
+        decode 'n' = "\n"
+        decode 'p' = (if hour < 12 then fst else snd) (amPm l)
+        decode 'R' = doFmt "%H:%M"
+        decode 'r' = doFmt (time12Fmt l)
+        decode 'T' = doFmt "%H:%M:%S"
+        decode 't' = "\t"
+        decode 'S' = show2 sec
+        decode 's' = ...                -- Implementation-dependent
+        decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7)
+        decode 'u' = show (let n = fromEnum wday in 
+                           if n == 0 then 7 else n)
+        decode 'V' = 
+            let (week, days) = 
+                   (yday + 7 - if fromEnum wday > 0 then 
+                               fromEnum wday - 1 else 6) `divMod` 7
+            in  show2 (if days >= 4 then
+                          week+1 
+                       else if week == 0 then 53 else week)
+
+        decode 'W' = 
+            show2 ((yday + 7 - if fromEnum wday > 0 then 
+                               fromEnum wday - 1 else 6) `div` 7)
+        decode 'w' = show (fromEnum wday)
+        decode 'X' = doFmt (timeFmt l)
+        decode 'x' = doFmt (dateFmt l)
+        decode 'Y' = show year
+        decode 'y' = show2 (year `rem` 100)
+        decode 'Z' = tzname
+        decode '%' = "%"
+        decode c   = [c]
+
+show2, show2', show3 :: Int -> String
+show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)]
+
+show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x
+
+show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100)
+
addfile ./lib/Typeable.hs
hunk ./lib/Typeable.hs 1
+module Typeable where
+
+class Typeable a where
+    typeOf :: a -> String
+    typeOf _ = "Unknown"
+
+instance Typeable Char where
+    typeOf _ = "Char"
+
+instance Typeable Bool where
+    typeOf _ = "Bool"
+
+instance Typeable a => Typeable [a] where
+    typeOf x = "[" ++ typeOf (head x) ++ "]"
+
addfile ./op_process.prl
hunk ./op_process.prl 1
+#!/usr/bin/perl -w 
+
+use strict;
+use Data::Dumper;
+
+open OP, "<data/operators.txt";
+
+my @fl;
+my @in;
+
+my @add;
+my %stuff;
+
+while(<OP>) {
+    chomp;
+    next unless /\S/;
+    next if /^\s*#/;
+    if (/^\[([\w,\s]*)\]\s*$/) {
+        @add = split(/\s*,\s*/,$1);
+        next;
+    }
+    my @a = split /\s*,\s*/;
+    foreach my $y (@add) {
+        push @{$stuff{$y}}, \@a;
+    }
+#    push @fl, \@a unless $add eq 'int'; 
+#    push @in, \@a unless $add eq 'float'; 
+}
+
+my @ds;
+open PR, "<data/primitives.txt";
+while(<PR>) {
+    chomp;
+    next unless /\S/;
+    next if /^\s*#/;
+    my @a = split /\s*,\s*/;
+    push @ds, \@a;
+}
+
+#print Dumper(\@fl,\@in,\@ds);
+
+my @inst; 
+my @meth;
+my @cmeth;
+my @names;
+my %seen;
+
+sub const($$@) {
+    my ($v,$t,$ct) = @_;
+    $ct ||= "\"int\"";
+    if ($v =~ /^\d/) {
+        return "prim_number $v $ct $t";
+
+        #return "ELit (LitInt $v $t)"; 
+    } else {       
+        #return "EPrim \"prim_const.$v\" [] $t"
+        #return "EPrim (primPrim \"prim_const.$v\") [] $t"
+        return "prim_const \"$v\" $ct $t";
+    }
+} 
+
+#print STDERR Dumper(\%stuff);
+
+my %tcon;
+sub tcon($) { 
+    return $tcon{$_[0]}[0] if $tcon{$_[0]};
+    my $n = $_[0];
+    $n =~ s/\W/_/g;
+    $n = "t_" . $n;
+    my $v = "$n = ELit (LitCons (parseName TypeConstructor \"$_[0]\") [] eStar)";
+    $tcon{$_[0]} = [$n,$v];
+    return $n;
+}
+
+my %dcon;
+sub dcon($) { 
+    return $dcon{$_[0]}[0] if $dcon{$_[0]};
+    my $n = $_[0];
+    $n =~ s/\W/_/g;
+    $n = "d_" . $n;
+    my $v = "$n = parseName DataConstructor \"$_[0]\"";
+    $dcon{$_[0]} = [$n,$v];
+    return $n;
+}
+
+my %hsname;
+sub hsname($) { 
+    return $hsname{$_[0]}[0] if $hsname{$_[0]};
+    my $n = $_[0];
+    $n =~ s/\W/_/g;
+    $n = "n_" . $n;
+    my $v = "$n = toHsName \"$_[0]\"";
+    $hsname{$_[0]} = [$n,$v];
+    return $n;
+}
+
+my %tycon;
+sub tycon($) { 
+    return $tycon{$_[0]}[0] if $tycon{$_[0]};
+    my $n = $_[0];
+    $n =~ s/\W/_/g;
+    $n = "tc_" . $n;
+    my $v = "$n = TCon (Tycon (toHsName \"$_[0]\") Star)";
+    $tycon{$_[0]} = [$n,$v];
+    return $n;
+}
+
+foreach my $d (@ds) {
+    #my @cs = ($d->[2] =~ /int/) ? @in : @fl;
+    my @cs = @{$stuff{$d->[2]}};
+    my $t = tcon($d->[0]);
+    #my $t =  "(ELit (LitCons (parseName TypeConstructor \"$d->[0]\") [] eStar) )";
+    #my $t =  "(ELit (LitCons $nn [] eStar) )";
+    my $tycon = tycon($d->[0]);
+    my $cncons = dcon($d->[0]);
+    #push @inst, "[] :=> IsIn (toHsName \"Prelude.Bounded\") (TCon \$ Tycon (toHsName \"$d->[0]\") Star)\n" unless $seen{'Prelude.Bounded',$d->[0]}++;
+    #push @inst, "[] :=> IsIn (toHsName \"Foreign.Storable.Storable\") (TCon \$ Tycon (toHsName \"$d->[0]\") Star)\n";
+    my $prelude_bounded = hsname("Prelude.Bounded");
+    my $foreign_storable = hsname("Foreign.Storable.Storable");
+    push @inst, "[] :=> IsIn $prelude_bounded $tycon";
+    push @inst, "[] :=> IsIn $foreign_storable $tycon";
+    push @cmeth, "(toInstName \"Foreign.Storable.sizeOf.$d->[0]\", ELam (tVr 0 $t) \$ " . const("sizeof($d->[1])","tInt") . ")";
+    push @cmeth, "(toInstName \"Foreign.Storable.poke.$d->[0]\", buildPoke $cncons $t \"$d->[1]\")";
+    push @cmeth, "(toInstName \"Foreign.Storable.peek.$d->[0]\", buildPeek $cncons $t \"$d->[1]\")";
+    push @cmeth, "(toInstName \"Prelude.maxBound.$d->[0]\", " . const($d->[3],$t,"\"$d->[1]\"") . ")";
+    push @cmeth, "(toInstName \"Prelude.minBound.$d->[0]\", " . const($d->[4],$t,"\"$d->[1]\"") . ")";
+    my $ivar = "(tVr 2 tInt)"; 
+    my $ivart = "(tVr 2 tInteger)"; 
+    my $tvar = "(tVr 2 $t)"; 
+    if ($d->[0] eq "Prelude.Int") {
+        push @cmeth, "(toInstName \"Prelude.fromInt.$d->[0]\", ELam $ivar (EVar $ivar))";
+        push @cmeth, "(toInstName \"Prelude.toInt.$d->[0]\", ELam $ivar (EVar $ivar))";
+    } else {
+        push @cmeth, "(toInstName \"Prelude.fromInt.$d->[0]\", ELam $ivar (prim_integralCast (EVar $ivar) $t))";
+        push @cmeth, "(toInstName \"Prelude.toInt.$d->[0]\", ELam $tvar (prim_integralCast (EVar $tvar) tInt))" if $d->[2] =~ /int/ ;
+    }
+    if ($d->[0] eq "Prelude.Integer") {
+        push @cmeth, "(toInstName \"Prelude.fromInteger.$d->[0]\", ELam $ivart (EVar $ivart))";
+        push @cmeth, "(toInstName \"Prelude.toInteger.$d->[0]\", ELam $ivart (EVar $ivart))";
+    } else {
+        push @cmeth, "(toInstName \"Prelude.fromInteger.$d->[0]\", ELam $ivart (prim_integralCast (EVar $ivart) $t))";
+        push @cmeth, "(toInstName \"Prelude.toInteger.$d->[0]\", ELam $tvar (prim_integralCast (EVar $tvar) tInteger))" if $d->[2] =~ /int/ ;
+    }
+    #push @cmeth, "(toInstName \"Prelude.abs.$d->[0]\", ELam $tvar (buildAbs $tvar $t))" if $d->[2] =~ /int/ ;
+    push @cmeth, "(toInstName \"Prelude.abs.$d->[0]\", ELam $tvar (build_abs \"$d->[1]\" $cncons (EVar $tvar)  ))" if $d->[2] =~ /int/ ;
+    #push @cmeth, "(toInstName \"Prelude.signum.$d->[0]\", ELam $tvar (buildSignum $tvar $t))" if $d->[2] =~ /int/ ;
+    push @cmeth, "(toInstName \"Prelude.signum.$d->[0]\", ELam $tvar (build_signum \"$d->[1]\" $cncons (EVar $tvar) ))" if $d->[2] =~ /int/ ;
+    push @names, "(\"$d->[0]\", \"$d->[1]\")\n";
+    foreach my $c (@cs) {
+        my $tycon = tycon($d->[0]);
+        my $nn = hsname($c->[2]);
+        #push @inst, "[] :=> IsIn (toHsName \"$c->[2]\") (TCon \$ Tycon (toHsName \"$d->[0]\") Star)\n" unless $seen{$c->[2],$d->[0]}++;
+        push @inst, "[] :=> IsIn $nn $tycon" unless $seen{$c->[2],$d->[0]}++;
+        my $x = $c->[2];
+        $x =~ s/^([\w.]+\.).*$/$1/;
+        if ($c->[0] =~ /^a[aI][aIB]?$/) {
+        push @cmeth, "(toInstName \"$x$c->[1].$d->[0]\", op_$c->[0]  \"$c->[3]\" \"$d->[1]\" $cncons $t)";
+        } else {
+        push @meth, "(toInstName \"$x$c->[1].$d->[0]\", \"$c->[0]\", \"prim_op_$c->[0].$c->[3]\", \"$d->[0]\")";
+    }
+    }
+}
+
+my $head = `cat data/PrimitiveOperators-in.hs`;
+print "$head\n";
+#print "{- This file is generated -}\n";
+#print "module PrimitiveOperators(primitiveInsts,constantMethods,theMethods,allCTypes) where\n\n";
+#print "import Representation\n";
+#print "import E.E\n";
+#print "import E.Values\n";
+#print "import C.Prims\n";
+#print "import VConsts\n";
+#print "import Name\n\n";
+#print "toHsName x = nameName \$ parseName TypeConstructor x\n\n";
+#print "toInstName x = toName Val (\"Instance@\",'i':x)\n\n";
+#print 'buildAbs v t = eIf (EPrim (primPrim "prim_op_aaB.<") [EVar v,(ELit (LitInt 0 t))] tBool) (EPrim (primPrim "prim_op_aa.-") [EVar v] t) (EVar v)'. "\n\n";
+#print 'buildSignum v t = eCase (EVar v) [Alt (LitInt 0 t) (ELit (LitInt 0 t))] (eIf (EPrim (primPrim "prim_op_aaB.<") [EVar v,(ELit (LitInt 0 t))] tBool) (ELit (LitInt (-1) t)) (ELit (LitInt 1  t)))' . "\n\n";  
+print "primitiveInsts = [\n   ", join("\n  ,",@inst), " ]\n\n";
+print "constantMethods = [\n   ", join("\n  ,",@cmeth), " ]\n\n";
+print "theMethods = [\n   ", join("\n  ,",@meth), " ]\n\n";
+push @names, "(\"Prelude.()\",\"void\")";
+print "allCTypes = [\n   ", join("  ,",@names), " ]\n\n";
+
+print join("\n",map { $_->[1] } values %tcon) . "\n\n"; 
+print join("\n",map { $_->[1] } values %tycon) . "\n\n"; 
+print join("\n",map { $_->[1] } values %hsname) . "\n\n"; 
+print join("\n",map { $_->[1] } values %dcon) . "\n\n"; 
+
+print "\n\n";
+
+
+
+#    push @cmeth, "(toName Val (\"Instance@\",\"iForeign.Storable.sizeOf.$d->[0]\"), ELam (TVr 0 $t) \$ " . const("sizeof($d->[1])","tInt") . ")\n";
+#    push @cmeth, "(toName Val (\"Instance@\",\"iForeign.Storable.poke.$d->[0]\"), buildPoke $t \"$d->[1]\")\n";
+#    push @cmeth, "(toName Val (\"Instance@\",\"iForeign.Storable.peek.$d->[0]\"), buildPeek $t \"$d->[1]\")\n";
+#    push @cmeth, "(toName Val (\"Instance@\",\"iPrelude.maxBound.$d->[0]\"), " . const($d->[3],$t,"\"$d->[1]\"") . ")\n";
+#    push @cmeth, "(toName Val (\"Instance@\",\"iPrelude.minBound.$d->[0]\"), " . const($d->[4],$t,"\"$d->[1]\"") . ")\n";
+
addfile ./op_raw.prl
hunk ./op_raw.prl 1
+#!/usr/bin/perl -w 
+
+use strict;
+
+
+my $mod = shift @ARGV;
+
+print "module $mod where\n\n\n"; 
+
+while (@ARGV) {
+    my $fn = shift @ARGV;
+    my $nn = lc $fn;
+    $nn =~ s/^.*\///;
+    $nn =~ s/\W/_/g;
+
+    open F, "<:utf8", $fn;
+
+    $fn =~ s{/}{\\/}g;
+    print "-- | Generated from $fn on " . `date`;
+    print "$nn :: String\n";
+    print "$nn = \"\\\n \\";
+    #print "$nn = \"";
+    while (<F>) {
+        chomp;
+        s/\\/\\\\/g;
+        s/[^\x20-\x7e]/sprintf("\\x%04x\\&", ord($&))/eg;
+
+        s/\"/\\"/g;
+        print "$_\\n\\\n \\";
+        #print "$_\\n";
+    }
+
+    print "\"\n\n";
+}
+
+
+print "\n\n";
addfile ./opt_sets.prl
hunk ./opt_sets.prl 1
+#!/usr/bin/perl 
+
+
+use strict;
+
+use Getopt::Std;
+
+my %h;
+getopts("n:",\%h);
+
+die "no name" unless $h{n};
+my $name = $h{n};
+$name =~ s/\.[a-z]+$//;
+
+my @l;
+my %h;
+
+# this is fun
+my $cat;
+my %cat;
+my @cat;
+
+while (<>) {
+    next unless /\S/;
+    next if /^\s*#/;
+    if (/^([a-z-]+)\s+(\S.*\S)\s*$/) {
+        my @xs = ($1,$2);
+        my $n = $1;
+        my ($v,$d) = ($1,$2);
+        $n =~ s/-([^-]*)/\u$1/g;
+        #push @l,["\u$n",$1,$2];
+        $h{$v} = {hname => "\u$n", oname => $v, desc => $d, cat => $cat  };
+        push @{$cat{$cat}}, $v;
+        unshift @xs, "\u$n";
+        push @l,\@xs;
+    } elsif (/^\@([a-z-]+)\s+(\S.*\S)\s*$/) {
+        $h{$1} = { oname => $1, cat => $cat, desc => $2, vals => [split(/\s+/,$2)] };
+        push @{$cat{$cat}}, $1;
+    } elsif (/^!(.*)\s*$/) {
+        push @cat,$1;
+        $cat = $1;
+        }
+}
+
+
+my @ds;
+foreach (@l) {
+    my $h = $_->[2];
+    $h =~ s{/}{\\/}g;
+    push @ds, (sprintf "%-17s -- ^ %s",$_->[0],$h);
+}
+@ds = sort @ds;
+
+print "module $name(Flag(..),process,helpMsg) where\n\n";
+print "import qualified Data.Set as Set\n";
+print "\n";
+print "-- | Flags\n";
+print "data Flag =\n      ";
+print join "\n    | ", @ds;
+print "\n    deriving(Eq,Ord,Bounded)\n";
+
+print "\ninstance Show Flag where\n"; 
+foreach (@l) {
+    print "    show $_->[0] = \"$_->[1]\"\n";
+}
+print "\n";
+
+
+foreach (keys %h) {
+    if ($h{$_}{hname}) { 
+        print "one \"$_\" = Right \$ Set.insert $h{$_}{hname}\n";
+        print "one \"no-$_\" = Right \$ Set.delete $h{$_}{hname}\n";
+    } else {
+        print "one \"$_\" = Right \$ foldr (.) id [ f | Right f <- [ " . join(",",( map { "one \"$_\"" } @{$h{$_}{vals}})) . "]]\n"
+    }
+}
+print "one x = Left x\n";
+
+
+print "\nprocess s xs = foldr f (s,[]) (map one xs) where\n";
+print "   f (Right g) (s,xs) = (g s,xs)\n";
+print "   f (Left x) (s,xs) = (s,x:xs)\n";
+
+
+my $help = "";
+
+foreach (@cat) {
+    $help .= "\\n-- $_ --\\n";
+    foreach my $j (sort @{$cat{$_}}) {
+        $help .= " $h{$j}{oname}\\n    $h{$j}{desc}\\n";
+    }
+}
+
+print "\nhelpMsg = \"$help\"\n";
+
+
+
+
+
addfile ./regress_test.prl
hunk ./regress_test.prl 1
+#!/usr/bin/perl
+
+use strict;
+use Getopt::Std;
+use Data::Dumper;
+use POSIX qw(strftime);
+
+
+#my %o;
+#getopts('k', \%o);
+
+my @summary;
+my @gc;
+
+my $file = shift @ARGV;
+open F, "<$file";
+
+my $err;
+
+
+while(<F>) {
+        next unless /^\-\-R ([A-Z.a-z_'0-9]+)\s+(.+?)\s*$/; 
+        my ($v,$r) = ($1,$2);
+        print "=> $v -> $r\n"; 
+        my $st = time;
+        system("./jhc",$file, '-m', $v, @ARGV)  == 0 or (1 ? (print "Program failed: $?\n") : (die "Program failed: $?"));
+        system("./hs.out")  == 0 or (1 ? (print "Program failed: $?\n") : (die "Program failed: $?")) if $? == 0;
+        #push @gc, ("$v - " . `cat jhc.stat`);
+
+        #print "-> $v -> $r\n"; 
+        $err++ if $?;
+        my $t = time - $st;
+        push @summary, sprintf "%s %13s: %5.1f %i", $ARGV,$v, $t, $?;
+        last if $? > 64000;
+        #system("./jhc '$file' -I -m '$v' +RTS -Pa && mv jhc.prof prof/$v.prof") == 0 or die "Program failed: $?";
+} 
+   
+my $now_string = strftime "%a %b %e %H:%M:%S %Y", localtime;
+my $args = "$file " . join(" ", @ARGV);
+print "---\n",join("\n",@summary),"\n";
+open (LOG, ">>regress.log");
+print LOG "---\n$args - $now_string \n ",join("\n",@summary),"\n".join("\n",@gc),"\n";
+exit $err;