More progress

5 files changed, 768 insertions, 18 deletions

diff --git a/src/Binary2.hs b/src/Binary2.hs
new file mode 100644
index 00000000..2d8b361e
--- /dev/null
+++ b/src/Binary2.hs
@@ -0,0 +1,687 @@
+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
+--
+-- (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/
+
+module Binary2
+  ( {-type-}  Bin,
+    {-class-} Binary(..),
+    {-type-}  BinHandle,
+
+   openBinIO, 
+   openBinIO_,
+   openBinMem,
+--   closeBin,
+
+--   getUserData,
+
+   seekBin,
+   tellBin,
+   castBin,
+
+   writeBinMem,
+   readBinMem,
+
+   isEOFBin,
+
+   -- for writing instances:
+   putByte,
+   getByte,
+
+   putString,
+   getString,
+
+   -- lazy Bin I/O
+   lazyGet,
+   lazyPut,
+
+   -- GHC only:
+   ByteArray(..),
+   getByteArray,
+   putByteArray,
+
+--   getBinFileWithDict,	-- :: Binary a => FilePath -> IO a
+--   putBinFileWithDict,	-- :: Binary a => FilePath -> Module -> a -> IO ()
+
+    -- re-export for the benefit of other modules.
+   openBinaryFile, 
+
+   FormatVersion,
+   nullFormatVersion,
+   mkFormatVersion,
+  ) where
+
+#include "MachDeps.h"
+
+import FastMutInt
+
+import Char
+import Monad
+
+#if __GLASGOW_HASKELL__ < 503
+import IOExts
+import Bits
+import Int
+import Word
+import Char
+import Monad
+import Exception
+import GlaExts hiding (ByteArray, newByteArray, freezeByteArray)
+import Array
+import IO
+import PrelIOBase		( IOError(..), IOErrorType(..)
+#if __GLASGOW_HASKELL__ > 411
+				, IOException(..)
+#endif
+				)
+import PrelReal			( Ratio(..) )
+import PrelIOBase	 	( IO(..) )
+#else
+import Data.Array.IO
+import Data.Array
+import Data.Bits
+import Data.Int
+import Data.Word
+import Data.IORef
+import Data.Char		( ord, chr )
+import Data.Array.Base  	( unsafeRead, unsafeWrite )
+import Control.Monad		( when )
+import 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(..) )
+#if __GLASGOW_HASKELL__ < 601
+-- openFileEx is available from the lang package, but we want to 
+-- be independent of hslibs libraries.
+import GHC.Handle		( openFileEx, IOModeEx(..) )
+#endif
+#endif
+
+import IO
+
+#if __GLASGOW_HASKELL__ < 601
+openBinaryFile f mode = openFileEx f (BinaryMode mode)
+#endif
+
+#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_HSINT
+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
+#endif
+
+#ifndef SIZEOF_HSWORD
+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
+#endif
+
+#else
+type BinArray = IOUArray Int Word8
+#endif
+
+data BinHandle
+  = BinMem {		-- binary data stored in an unboxed array
+     state :: Int,	-- sigh, need parameterized modules :-)
+     off_r :: !FastMutInt,		-- the current offset
+     sz_r  :: !FastMutInt,		-- size of the array (cached)
+     arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))
+    }
+	-- XXX: should really store a "high water mark" for dumping out
+	-- the binary data to a file.
+
+  | BinIO {		-- binary data stored in a file
+     state :: Int,
+     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.
+
+newtype Bin a = BinPtr Int 
+  deriving (Eq, Ord, Show, Bounded)
+
+castBin :: Bin a -> Bin b
+castBin (BinPtr i) = BinPtr i
+
+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 undefined 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_r0 <- newIORef arr
+   ix_r <- newFastMutInt
+   writeFastMutInt ix_r 0
+   sz_r0 <- newFastMutInt
+   writeFastMutInt sz_r0 size
+   return (BinMem undefined ix_r sz_r0 arr_r0)
+
+--noBinHandleUserData :: a
+--noBinHandleUserData = error "Binary.BinHandle: no user data"
+
+--getUserData :: BinHandle -> BinHandleState
+--getUserData bh = state bh
+
+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_r0 _) (BinPtr p) = do
+  sz <- readFastMutInt sz_r0
+  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_r0 _) = do
+  ix <- readFastMutInt ix_r
+  sz <- readFastMutInt sz_r0
+  return (ix >= sz)
+isEOFBin (BinIO _ _ h) = hIsEOF h
+
+writeBinMem :: BinHandle -> FilePath -> IO ()
+writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
+writeBinMem (BinMem _ ix_r _ arr_r0) fn = do
+  h <- openBinaryFile fn WriteMode
+  arr <- readIORef arr_r0
+  ix  <- readFastMutInt ix_r
+  hPutArray h arr ix
+  hClose h
+
+readBinMem :: FilePath -> IO BinHandle
+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_r0 <- newIORef arr
+  ix_r <- newFastMutInt
+  writeFastMutInt ix_r 0
+  sz_r0 <- newFastMutInt
+  writeFastMutInt sz_r0 filesize
+  return (BinMem undefined {-initReadState-} ix_r sz_r0 arr_r0)
+
+-- expand the size of the array to include a specified offset
+expandBin :: BinHandle -> Int -> IO ()
+expandBin (BinMem _ _ sz_r0 arr_r0) off = do
+   sz <- readFastMutInt sz_r0
+   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
+   arr <- readIORef arr_r0
+   arr' <- newArray_ (0,sz'-1)
+   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
+ 	     | i <- [ 0 .. sz-1 ] ]
+   writeFastMutInt sz_r0 sz'
+   writeIORef arr_r0 arr'
+   hPutStrLn stderr ("expanding to size: " ++ show sz')
+   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_r0 arr_r0) w = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r0
+	-- 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_r0
+		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_r0 arr_r0) = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r0
+    when (ix >= sz)  $
+	ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+    arr <- readIORef arr_r0
+    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
+
+-- | Get the next byte, but don't change the pointer.
+peekWord8 :: BinHandle -> IO Word8
+peekWord8 (BinMem _ ix_r sz_r0 arr_r0) = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r0
+    when (ix >= sz)  $
+	ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+    arr <- readIORef arr_r0
+    w <- unsafeRead arr ix
+    return w
+peekWord8 (BinIO _ ix_r h) = do
+    c <- hLookAhead h
+    return $! (fromIntegral (ord c))	-- XXX not really correct
+
+putByte :: BinHandle -> Word8 -> IO ()
+putByte bh w = put_ bh w
+
+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_ _ () = 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
+--    getF bh   = getBitsF bh 32
+
+{-
+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 [a] where
+    put_ bh l =
+	do put_ bh (length l)
+	   mapM (put_ bh) l
+	   return ()
+    get bh =
+	do len <- get bh
+	   mapM (\_ -> get bh) [1..(len::Int)]
+
+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 b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
+    put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         return (a,b,c,d,e)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where
+    put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         f <- get bh
+                         return (a,b,c,d,e,f)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f,Binary g) => Binary (a,b,c,d,e,f,g) where
+    put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         f <- get bh
+                         g <- get bh
+                         return (a,b,c,d,e,f,g)
+
+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)
+
+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 $ \s0 ->
+  case newByteArray# sz s0 of { (# s, arr #) ->
+  (# s, MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr0 = IO $ \s0 ->
+  case unsafeFreezeByteArray# arr0 s0 of { (# s, arr #) ->
+  (# s, BA arr #) }
+
+writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
+
+writeByteArray arr i w8 = IO $ \s0 ->
+  case fromIntegral w8 of { W# w# -> 
+  case writeCharArray# arr i (chr# (word2Int# w#)) s0  of { s ->
+  (# s , () #) }}
+
+indexByteArray :: ByteArray# -> Int# -> Word8
+indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# 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)
+
+instance Binary (Bin a) where
+  put_ bh (BinPtr i) = put_ bh i
+  get bh = do i <- get bh; return (BinPtr i)
+
+-- -----------------------------------------------------------------------------
+-- Strings
+
+-- should put a string in UTF-8 (just throws away top 24 bits at the moment)
+putString :: BinHandle -> String -> IO ()
+putString bh str = put_ bh word8s
+ where
+  word8s :: [Word8]
+  word8s = map (fromIntegral.ord) str
+
+getString :: BinHandle -> IO String
+getString bh = do
+  word8s <- get bh
+  return (map (chr.fromIntegral) (word8s :: [Word8]))
+
+-- -----------------------------------------------------------------------------
+-- 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
+
+-- -----------------------------------------------------------------------------
+-- FormatVersion's.  
+-- The FormatVersion is always non-negative.  Furthermore, if the 
+-- FormatVersion is 0, nothing is output.
+-- 
+-- FormatVersion should only be encoded before something we KNOW to have
+-- an encoding which never begins with a negative byte, such as a non-negative
+-- integer or a list.
+-- 
+-- The advantage of this is that we can read a FormatVersion (which will
+-- be the nullFormatVersion) even when we didn't write one in the first
+-- place, such as from earlier versions of this program, just so long
+-- as we did at any rate write a list.
+
+newtype FormatVersion = FormatVersion Int deriving (Eq,Ord)
+
+nullFormatVersion :: FormatVersion
+nullFormatVersion = mkFormatVersion 0
+
+mkFormatVersion :: Int -> FormatVersion
+mkFormatVersion i = FormatVersion i
+
+instance Binary FormatVersion where
+   put_ bh (FormatVersion i) =
+      case compare i 0 of
+         EQ -> return ()
+         GT -> put_ bh (-i)
+         LT -> error (
+            "Binary.hs: negative FormatVersion " ++ show i 
+               ++ " is not allowed")
+   get bh =
+      do
+         w8 <- peekWord8 bh   
+         if testBit w8 7
+            then
+               do
+                  i <- get bh
+                  return (FormatVersion (-i))
+            else
+               return nullFormatVersion
diff --git a/src/FastMutInt2.hs b/src/FastMutInt2.hs
new file mode 100644
index 00000000..a197a448
--- /dev/null
+++ b/src/FastMutInt2.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Unboxed mutable Ints
+
+module FastMutInt2(
+	FastMutInt, newFastMutInt,
+	readFastMutInt, writeFastMutInt,
+	incFastMutInt, incFastMutIntBy
+  ) where
+
+#include "MachDeps.h"
+
+#ifndef SIZEOF_HSINT
+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
+#endif
+
+
+#if __GLASGOW_HASKELL__ < 503
+import GlaExts
+import PrelIOBase
+#else
+import GHC.Base
+import GHC.IOBase
+#endif
+
+#if __GLASGOW_HASKELL__ < 411
+newByteArray# = newCharArray#
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
+
+newFastMutInt :: IO FastMutInt
+newFastMutInt = IO $ \s0 ->
+  case newByteArray# size s0 of { (# s, arr #) ->
+  (# s, FastMutInt arr #) }
+  where I# size = SIZEOF_HSINT
+
+readFastMutInt :: FastMutInt -> IO Int
+readFastMutInt (FastMutInt arr) = IO $ \s0 ->
+  case readIntArray# arr 0# s0 of { (# s, i #) ->
+  (# s, I# i #) }
+
+writeFastMutInt :: FastMutInt -> Int -> IO ()
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s0 ->
+  case writeIntArray# arr 0# i s0 of { s ->
+  (# s, () #) }
+
+incFastMutInt :: FastMutInt -> IO Int	-- Returns original value
+incFastMutInt (FastMutInt arr) = IO $ \s0 ->
+  case readIntArray# arr 0# s0 of { (# s1, i #) ->
+  case writeIntArray# arr 0# (i +# 1#) s1 of { s ->
+  (# s, I# i #) } }
+
+incFastMutIntBy :: FastMutInt -> Int -> IO Int	-- Returns original value
+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s0 ->
+  case readIntArray# arr 0# s0 of { (# s1, i #) ->
+  case writeIntArray# arr 0# (i +# n) s1 of { s ->
+  (# s, I# i #) } }
+#endif
+
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 31254702..6fc9d21a 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -32,6 +32,7 @@ import Data.List ( sortBy )
 import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe )
 import Foreign.Marshal.Alloc ( allocaBytes )
 import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf )
+import Debug.Trace ( trace )
 
 import GHC 
 import Name
@@ -41,7 +42,7 @@ import SrcLoc
 import FastString ( unpackFS )
 import BasicTypes ( IPName(..), Boxity(..) )
 import Kind
---import Outputable ( ppr, defaultUserStyle )
+import Outputable ( ppr, defaultUserStyle )
 
 -- the base, module and entity URLs for the source code and wiki links.
 type SourceURLs = (Maybe String, Maybe String, Maybe String)
@@ -556,7 +557,7 @@ hmodToHtml maybe_source_url maybe_wiki_url hmod
 
 	no_doc_at_all = not (any has_doc exports)
 
-	contents = td << vanillaTable << ppModuleContents exports
+ 	contents = td << vanillaTable << ppModuleContents exports
 
 	description
           = case hmod_rn_doc hmod of
@@ -715,7 +716,10 @@ ppTyVars tvs = map ppName (tyvarNames tvs)
 tyvarNames = map f 
   where f x = let NoLink n = hsTyVarName (unLoc x) in n
   
-ppFor = undefined
+ppFor summary links loc mbDoc (ForeignImport lname ltype _ _)
+  = ppSig summary links loc mbDoc (TypeSig lname ltype)
+ppFor _ _ _ _ _ = error "ppFor"
+
 ppDataDecl = undefined
 
 ppTySyn summary links loc mbDoc (TySynonym lname ltyvars ltype) 
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index ae9c3d8b..5dace7b8 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -140,3 +140,13 @@ data DocMarkup id a = Markup {
   markupURL           :: String -> a,
   markupAName         :: String -> a
 }
+
+instance (Outputable a, OutputableBndr a) => Outputable (ExportItem2 a) where
+  ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> ppr instns
+  ppr (ExportNoDecl2 n1 n2 ns) = text "ExportNoDecl (org name, link name, sub names)" <+> ppr n1 <+> ppr n2 <+> ppr ns
+  ppr (ExportGroup2 lev id doc) = text "ExportGroup (lev, id, doc)" <+> ppr lev <+> ppr doc
+  ppr (ExportDoc2 doc) = text "ExportDoc" <+> ppr doc
+  ppr (ExportModule2 mod) = text "ExportModule" <+> ppr mod 	
+
+instance OutputableBndr DocName where
+  pprBndr _ d = ppr d
diff --git a/src/Main.hs b/src/Main.hs
index 73f31581..f77ad1f1 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -292,7 +292,7 @@ run flags files = do
   printSDoc (ppr (map hmod_rn_export_items haddockModules'')) defaultUserStyle 
   mapM_ putStrLn messages'
 
-  let visibleModules = [ m | m <- haddockModules', OptHide `notElem` (hmod_options m) ]
+  let visibleModules = [ m | m <- haddockModules'', OptHide `notElem` (hmod_options m) ]
  
   updateHTMLXRefs [] []
 
@@ -399,20 +399,6 @@ run flags files = do
 
 print_ x = printSDoc (ppr x) defaultUserStyle        
 
-instance (Outputable a, OutputableBndr a) => Outputable (ExportItem2 a) where
-  ppr (ExportDecl2 n decl doc instns) = text "ExportDecl" <+> ppr n <+> ppr decl <+> ppr doc <+> ppr instns
-  ppr (ExportNoDecl2 n1 n2 ns) = text "ExportNoDecl (org name, link name, sub names)" <+> ppr n1 <+> ppr n2 <+> ppr ns
-  ppr (ExportGroup2 lev id doc) = text "ExportGroup (lev, id, doc)" <+> ppr lev <+> ppr doc
-  ppr (ExportDoc2 doc) = text "ExportDoc" <+> ppr doc
-  ppr (ExportModule2 mod) = text "ExportModule" <+> ppr mod 	
-
---instance Outputable DocName where
---  ppr (Link name) = ppr name
---  ppr (NoLink name) = ppr name
-
-instance OutputableBndr DocName where
-  pprBndr _ d = ppr d
-
 instance Outputable (DocEntity Name) where
   ppr (DocEntity d) = ppr d
   ppr (DeclEntity name) = ppr name