Initial modifications -- doesn't compile

21 files changed, 317 insertions, 2018 deletions

diff --git a/src/Binary.hs b/src/Binary.hs
deleted file mode 100644
index f1c98620..00000000
--- a/src/Binary.hs
+++ /dev/null
@@ -1,687 +0,0 @@
-{-# 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 Binary
-  ( {-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/Digraph.lhs b/src/Digraph.lhs
deleted file mode 100644
index a7a04d49..00000000
--- a/src/Digraph.lhs
+++ /dev/null
@@ -1,416 +0,0 @@
---
--- Taken from ghc/compiler/utils/Digraph.lhs v1.15
--- (c) The University of Glasgow, 2002
---
-
-\begin{code}
-{-# OPTIONS -cpp #-}
-module Digraph(
-
-	-- At present the only one with a "nice" external interface
-	stronglyConnComp, stronglyConnCompR, SCC(..), flattenSCC, flattenSCCs,
-
-	Graph, Vertex, 
-	graphFromEdges, buildG, transposeG, reverseE, outdegree, indegree,
-
-	Tree(..), Forest,
-	showTree, showForest,
-
-	dfs, dff,
-	topSort,
-	components,
-	scc,
-	back, cross, forward,
-	reachable, path,
-	bcc
-
-    ) where
-
-------------------------------------------------------------------------------
--- A version of the graph algorithms described in:
--- 
--- ``Lazy Depth-First Search and Linear Graph Algorithms in Haskell''
---   by David King and John Launchbury
--- 
--- Also included is some additional code for printing tree structures ...
-------------------------------------------------------------------------------
-
-
-#define ARR_ELT		(COMMA)
-
--- Extensions
-#if __GLASGOW_HASKELL__ < 503
-import ST
-#else
-import Control.Monad.ST
-import Data.Array.ST hiding (indices,bounds)
-#endif
-
--- std interfaces
-import Maybe
-import Array
-import List
-\end{code}
-
-
-%************************************************************************
-%*									*
-%*	External interface
-%*									*
-%************************************************************************
-
-\begin{code}
-data SCC vertex = AcyclicSCC vertex
-	        | CyclicSCC  [vertex]
-
-flattenSCCs :: [SCC a] -> [a]
-flattenSCCs = concatMap flattenSCC
-
-flattenSCC :: SCC vertex -> [vertex]
-flattenSCC (AcyclicSCC v) = [v]
-flattenSCC (CyclicSCC vs) = vs
-\end{code}
-
-\begin{code}
-stronglyConnComp
-	:: Ord key
-	=> [(node, key, [key])]		-- The graph; its ok for the
-					-- out-list to contain keys which arent
-					-- a vertex key, they are ignored
-	-> [SCC node]
-
-stronglyConnComp edges0
-  = map get_node (stronglyConnCompR edges0)
-  where
-    get_node (AcyclicSCC (n, _, _)) = AcyclicSCC n
-    get_node (CyclicSCC triples)     = CyclicSCC [n | (n,_,_) <- triples]
-
--- The "R" interface is used when you expect to apply SCC to
--- the (some of) the result of SCC, so you dont want to lose the dependency info
-stronglyConnCompR
-	:: Ord key
-	=> [(node, key, [key])]		-- The graph; its ok for the
-					-- out-list to contain keys which arent
-					-- a vertex key, they are ignored
-	-> [SCC (node, key, [key])]
-
-stronglyConnCompR [] = []  -- added to avoid creating empty array in graphFromEdges -- SOF
-stronglyConnCompR edges0
-  = map decode forest
-  where
-    (graph, vertex_fn) = graphFromEdges edges0
-    forest	       = scc graph
-    decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
-		       | otherwise	   = AcyclicSCC (vertex_fn v)
-    decode other = CyclicSCC (dec other [])
-		 where
-		   dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
-    mentions_itself v = v `elem` (graph ! v)
-\end{code}
-
-%************************************************************************
-%*									*
-%*	Graphs
-%*									*
-%************************************************************************
-
-
-\begin{code}
-type Vertex  = Int
-type Table a = Array Vertex a
-type Graph   = Table [Vertex]
-type Bounds  = (Vertex, Vertex)
-type Edge    = (Vertex, Vertex)
-\end{code}
-
-\begin{code}
-vertices :: Graph -> [Vertex]
-vertices  = indices
-
-edges    :: Graph -> [Edge]
-edges g   = [ (v, w) | v <- vertices g, w <- g!v ]
-
-mapT    :: (Vertex -> a -> b) -> Table a -> Table b
-mapT f t = array (bounds t) [ (,) v (f v (t!v)) | v <- indices t ]
-
-buildG :: Bounds -> [Edge] -> Graph
-buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 edges0
-
-transposeG  :: Graph -> Graph
-transposeG g = buildG (bounds g) (reverseE g)
-
-reverseE    :: Graph -> [Edge]
-reverseE g   = [ (w, v) | (v, w) <- edges g ]
-
-outdegree :: Graph -> Table Int
-outdegree  = mapT numEdges
-             where numEdges _ ws = length ws
-
-indegree :: Graph -> Table Int
-indegree  = outdegree . transposeG
-\end{code}
-
-
-\begin{code}
-graphFromEdges
-	:: Ord key
-	=> [(node, key, [key])]
-	-> (Graph, Vertex -> (node, key, [key]))
-graphFromEdges edges0
-  = (graph, \v -> vertex_map ! v)
-  where
-    max_v      	    = length edges0 - 1
-    bounds0          = (0,max_v) :: (Vertex, Vertex)
-    sorted_edges    = sortBy lt edges0
-    edges1	    = zipWith (,) [0..] sorted_edges
-
-    graph	    = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_,    _, ks) <- edges1]
-    key_map	    = array bounds0 [(,) v k			   | (,) v (_,    k, _ ) <- edges1]
-    vertex_map	    = array bounds0 edges1
-
-    (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2
-
-    -- key_vertex :: key -> Maybe Vertex
-    -- 	returns Nothing for non-interesting vertices
-    key_vertex k   = findVertex 0 max_v 
-		   where
-		     findVertex a b | a > b 
-			      = Nothing
-		     findVertex a b = case compare k (key_map ! mid) of
-				   LT -> findVertex a (mid-1)
-				   EQ -> Just mid
-				   GT -> findVertex (mid+1) b
-			      where
-			 	mid = (a + b) `div` 2
-\end{code}
-
-%************************************************************************
-%*									*
-%*	Trees and forests
-%*									*
-%************************************************************************
-
-\begin{code}
-data Tree a   = Node a (Forest a)
-type Forest a = [Tree a]
-
-mapTree              :: (a -> b) -> (Tree a -> Tree b)
-mapTree f (Node x ts) = Node (f x) (map (mapTree f) ts)
-\end{code}
-
-\begin{code}
-instance Show a => Show (Tree a) where
-  showsPrec _ t s = showTree t ++ s
-
-showTree :: Show a => Tree a -> String
-showTree  = drawTree . mapTree show
-
-showForest :: Show a => Forest a -> String
-showForest  = unlines . map showTree
-
-drawTree        :: Tree String -> String
-drawTree         = unlines . draw
-
-draw :: Tree String -> [String]
-draw (Node x ts0) = grp this (space (length this)) (stLoop ts0)
- where this          = s1 ++ x ++ " "
-
-       space n       = replicate n ' '
-
-       stLoop []     = [""]
-       stLoop [t]    = grp s2 "  " (draw t)
-       stLoop (t:ts) = grp s3 s4 (draw t) ++ [s4] ++ rsLoop ts
-
-       rsLoop []     = error "rsLoop:Unexpected empty list."
-       rsLoop [t]    = grp s5 "  " (draw t)
-       rsLoop (t:ts) = grp s6 s4 (draw t) ++ [s4] ++ rsLoop ts
-
-       grp fst0 rst   = zipWith (++) (fst0:repeat rst)
-
-       [s1,s2,s3,s4,s5,s6] = ["- ", "--", "-+", " |", " `", " +"]
-\end{code}
-
-
-%************************************************************************
-%*									*
-%*	Depth first search
-%*									*
-%************************************************************************
-
-\begin{code}
-#if __GLASGOW_HASKELL__ >= 504
-newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e)
-newSTArray = newArray
-
-readSTArray :: Ix i => STArray s i e -> i -> ST s e
-readSTArray = readArray
-
-writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s ()
-writeSTArray = writeArray
-#endif
-
-type Set s    = STArray s Vertex Bool
-
-mkEmpty      :: Bounds -> ST s (Set s)
-mkEmpty bnds  = newSTArray bnds False
-
-contains     :: Set s -> Vertex -> ST s Bool
-contains m v  = readSTArray m v
-
-include      :: Set s -> Vertex -> ST s ()
-include m v   = writeSTArray m v True
-\end{code}
-
-\begin{code}
-dff          :: Graph -> Forest Vertex
-dff g         = dfs g (vertices g)
-
-dfs          :: Graph -> [Vertex] -> Forest Vertex
-dfs g vs      = prune (bounds g) (map (generate g) vs)
-
-generate     :: Graph -> Vertex -> Tree Vertex
-generate g v  = Node v (map (generate g) (g!v))
-
-prune        :: Bounds -> Forest Vertex -> Forest Vertex
-prune bnds ts = runST (mkEmpty bnds  >>= \m ->
-                       chop m ts)
-
-chop         :: Set s -> Forest Vertex -> ST s (Forest Vertex)
-chop _ []     = return []
-chop m (Node v ts : us)
-              = contains m v >>= \visited ->
-                if visited then
-                  chop m us
-                else
-                  include m v >>= \_  ->
-                  chop m ts   >>= \as ->
-                  chop m us   >>= \bs ->
-                  return (Node v as : bs)
-\end{code}
-
-
-%************************************************************************
-%*									*
-%*	Algorithms
-%*									*
-%************************************************************************
-
-------------------------------------------------------------
--- Algorithm 1: depth first search numbering
-------------------------------------------------------------
-
-\begin{code}
-preorder            :: Tree a -> [a]
-preorder (Node a ts) = a : preorderF ts
-
-preorderF           :: Forest a -> [a]
-preorderF ts         = concat (map preorder ts)
-
-tabulate        :: Bounds -> [Vertex] -> Table Int
-tabulate bnds vs = array bnds (zipWith (,) vs [1..])
-
-preArr          :: Bounds -> Forest Vertex -> Table Int
-preArr bnds      = tabulate bnds . preorderF
-\end{code}
-
-
-------------------------------------------------------------
--- Algorithm 2: topological sorting
-------------------------------------------------------------
-
-\begin{code}
-postorder :: Tree a -> [a]
-postorder (Node a ts) = postorderF ts ++ [a]
-
-postorderF   :: Forest a -> [a]
-postorderF ts = concat (map postorder ts)
-
-postOrd      :: Graph -> [Vertex]
-postOrd       = postorderF . dff
-
-topSort      :: Graph -> [Vertex]
-topSort       = reverse . postOrd
-\end{code}
-
-
-------------------------------------------------------------
--- Algorithm 3: connected components
-------------------------------------------------------------
-
-\begin{code}
-components   :: Graph -> Forest Vertex
-components    = dff . undirected
-
-undirected   :: Graph -> Graph
-undirected g  = buildG (bounds g) (edges g ++ reverseE g)
-\end{code}
-
-
--- Algorithm 4: strongly connected components
-
-\begin{code}
-scc  :: Graph -> Forest Vertex
-scc g = dfs g (reverse (postOrd (transposeG g)))
-\end{code}
-
-
-------------------------------------------------------------
--- Algorithm 5: Classifying edges
-------------------------------------------------------------
-
-\begin{code}
-back              :: Graph -> Table Int -> Graph
-back g post        = mapT select g
- where select v ws = [ w | w <- ws, post!v < post!w ]
-
-cross             :: Graph -> Table Int -> Table Int -> Graph
-cross g pre post   = mapT select g
- where select v ws = [ w | w <- ws, post!v > post!w, pre!v > pre!w ]
-
-forward           :: Graph -> Graph -> Table Int -> Graph
-forward g tree pre = mapT select g
- where select v ws = [ w | w <- ws, pre!v < pre!w ] \\ tree!v
-\end{code}
-
-
-------------------------------------------------------------
--- Algorithm 6: Finding reachable vertices
-------------------------------------------------------------
-
-\begin{code}
-reachable    :: Graph -> Vertex -> [Vertex]
-reachable g v = preorderF (dfs g [v])
-
-path         :: Graph -> Vertex -> Vertex -> Bool
-path g v w    = w `elem` (reachable g v)
-\end{code}
-
-
-------------------------------------------------------------
--- Algorithm 7: Biconnected components
-------------------------------------------------------------
-
-\begin{code}
-bcc :: Graph -> Forest [Vertex]
-bcc g = (concat . map bicomps . map (do_label g dnum)) forest
- where forest = dff g
-       dnum   = preArr (bounds g) forest
-
-do_label :: Graph -> Table Int -> Tree Vertex -> Tree (Vertex,Int,Int)
-do_label g dnum (Node v ts) = Node (v,dnum!v,lv) us
- where us = map (do_label g dnum) ts
-       lv = minimum ([dnum!v] ++ [dnum!w | w <- g!v]
-                     ++ [lu | Node (u,du,lu) xs <- us])
-
-bicomps :: Tree (Vertex,Int,Int) -> Forest [Vertex]
-bicomps (Node (v,_,_) ts)
-      = [ Node (v:vs) us | (l,Node vs us) <- map collect ts]
-
-collect :: Tree (Vertex,Int,Int) -> (Int, Tree [Vertex])
-collect (Node (v,dv,lv) ts) = (lv, Node (v:vs) cs)
- where collected = map collect ts
-       vs = concat [ ws | (lw, Node ws us) <- collected, lw<dv]
-       cs = concat [ if lw<dv then us else [Node (v:ws) us]
-                        | (lw, Node ws us) <- collected ]
-\end{code}
-
diff --git a/src/FastMutInt.hs b/src/FastMutInt.hs
deleted file mode 100644
index 23001c1f..00000000
--- a/src/FastMutInt.hs
+++ /dev/null
@@ -1,63 +0,0 @@
-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
---
--- (c) The University of Glasgow 2002
---
--- Unboxed mutable Ints
-
-module FastMutInt(
-	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/HaddockDB.hs b/src/HaddockDB.hs
index a56ebada..bc6af5a6 100644
--- a/src/HaddockDB.hs
+++ b/src/HaddockDB.hs
@@ -9,7 +9,7 @@ module HaddockDB (ppDocBook) where
 {-
 import HaddockTypes
 import HaddockUtil
-import HsSyn
+import HsSyn2
 
 import Text.PrettyPrint
 -}
diff --git a/src/HaddockDevHelp.hs b/src/HaddockDevHelp.hs
index 390fb6f3..c16e474c 100644
--- a/src/HaddockDevHelp.hs
+++ b/src/HaddockDevHelp.hs
@@ -3,7 +3,7 @@ module HaddockDevHelp(ppDevHelpFile) where
 import HaddockModuleTree
 import HaddockTypes
 import HaddockUtil
-import HsSyn hiding(Doc)
+import HsSyn2 hiding(Doc)
 import qualified Map
 
 import Data.Maybe ( fromMaybe )
diff --git a/src/HaddockHH.hs b/src/HaddockHH.hs
index 59953575..937d382f 100644
--- a/src/HaddockHH.hs
+++ b/src/HaddockHH.hs
@@ -3,7 +3,7 @@ module HaddockHH(ppHHContents, ppHHIndex, ppHHProject) where
 import HaddockModuleTree
 import HaddockTypes
 import HaddockUtil
-import HsSyn hiding(Doc)
+import HsSyn2 hiding(Doc)
 import qualified Map
 
 import Data.Char ( toUpper )
diff --git a/src/HaddockHH2.hs b/src/HaddockHH2.hs
index 6d4ce5c0..c4804190 100644
--- a/src/HaddockHH2.hs
+++ b/src/HaddockHH2.hs
@@ -3,7 +3,7 @@ module HaddockHH2(ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where
 import HaddockModuleTree
 import HaddockTypes
 import HaddockUtil
-import HsSyn hiding(Doc)
+import HsSyn2 hiding(Doc)
 import qualified Map
 
 import Data.Char ( toUpper )
diff --git a/src/HaddockHoogle.hs b/src/HaddockHoogle.hs
index a846f58c..3b624cd6 100644
--- a/src/HaddockHoogle.hs
+++ b/src/HaddockHoogle.hs
@@ -13,7 +13,7 @@ module HaddockHoogle (
 
 import HaddockTypes
 import HaddockUtil
-import HsSyn
+import HsSyn2
 
 import Data.List ( intersperse )
 
diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs
index 5c6bd892..a383c85c 100644
--- a/src/HaddockHtml.hs
+++ b/src/HaddockHtml.hs
@@ -12,7 +12,7 @@ module HaddockHtml (
 
 import Prelude hiding (div)
 
-import Binary ( openBinaryFile )
+import Binary2 ( openBinaryFile )
 import HaddockDevHelp
 import HaddockHH
 import HaddockHH2
@@ -20,7 +20,7 @@ import HaddockModuleTree
 import HaddockTypes
 import HaddockUtil
 import HaddockVersion
-import HsSyn
+import HsSyn2
 import Html
 import qualified Html
 import Map ( Map )
diff --git a/src/HaddockLex.x b/src/HaddockLex.x
deleted file mode 100644
index f5e40942..00000000
--- a/src/HaddockLex.x
+++ /dev/null
@@ -1,168 +0,0 @@
---
--- Haddock - A Haskell Documentation Tool
---
--- (c) Simon Marlow 2002
---
-
-{
-module HaddockLex ( 
-	Token(..), 
-	tokenise 
- ) where
-
-import Char
-import Numeric
-import HsSyn
-import HsLexer hiding (Token)
-import HsParseMonad
---import Debug.Trace
-}
-
-$ws    = $white # \n
-$digit = [0-9]
-$hexdigit = [0-9a-fA-F]
-$special =  [\"\@\/]
-$alphanum = [A-Za-z0-9]
-$ident    = [$alphanum \'\_\.\!\#\$\%\&\*\+\/\<\=\>\?\@\\\\\^\|\-\~]
-
-:-
-
--- beginning of a paragraph
-<0,para> {
- $ws* \n		;
- $ws* \>		{ begin birdtrack }
- $ws* [\*\-]		{ token TokBullet `andBegin` string }
- $ws* \[		{ token TokDefStart `andBegin` def }
- $ws* \( $digit+ \) 	{ token TokNumber `andBegin` string }
- $ws*			{ begin string }		
-}
-
--- beginning of a line
-<line> {
-  $ws* \>		{ begin birdtrack }
-  $ws* \n		{ token TokPara `andBegin` para }
-  -- Here, we really want to be able to say
-  -- $ws* (\n | <eof>) 	{ token TokPara `andBegin` para}
-  -- because otherwise a trailing line of whitespace will result in 
-  -- a spurious TokString at the end of a docstring.  We don't have <eof>,
-  -- though (NOW I realise what it was for :-).  To get around this, we always
-  -- append \n to the end of a docstring.
-  () 			{ begin string }
-}
-
-<birdtrack> .*	\n?	{ strtoken TokBirdTrack `andBegin` line }
-
-<string,def> {
-  $special			{ strtoken $ \s -> TokSpecial (head s) }
-  \<.*\>			{ strtoken $ \s -> TokURL (init (tail s)) }
-  \#.*\#			{ strtoken $ \s -> TokAName (init (tail s)) }
-  [\'\`] $ident+ [\'\`]		{ ident }
-  \\ .				{ strtoken (TokString . tail) }
-  "&#" $digit+ \;		{ strtoken $ \s -> TokString [chr (read (init (drop 2 s)))] }
-  "&#" [xX] $hexdigit+ \;	{ strtoken $ \s -> case readHex (init (drop 3 s)) of [(n,_)] -> TokString [chr n] }
-  -- allow special characters through if they don't fit one of the previous
-  -- patterns.
-  [\'\`\<\#\&\\]			{ strtoken TokString }
-  [^ $special \< \# \n \'\` \& \\ \]]* \n { strtoken TokString `andBegin` line }
-  [^ $special \< \# \n \'\` \& \\ \]]+    { strtoken TokString }
-}
-
-<def> {
-  \]				{ token TokDefEnd `andBegin` string }
-}
-
--- ']' doesn't have any special meaning outside of the [...] at the beginning
--- of a definition paragraph.
-<string> {
-  \]				{ strtoken TokString }
-}
-
-{
-data Token
-  = TokPara
-  | TokNumber
-  | TokBullet
-  | TokDefStart
-  | TokDefEnd
-  | TokSpecial Char
-  | TokIdent [HsQName]
-  | TokString String
-  | TokURL String
-  | TokAName String
-  | TokBirdTrack String
-  deriving Show
-
--- -----------------------------------------------------------------------------
--- Alex support stuff
-
-type StartCode = Int
-type Action = String -> StartCode -> (StartCode -> [Token]) -> [Token]
-
-type AlexInput = (Char,String)
-
-alexGetChar (_, [])   = Nothing
-alexGetChar (_, c:cs) = Just (c, (c,cs))
-
-alexInputPrevChar (c,_) = c
-
-tokenise :: String -> [Token]
-tokenise str = let toks = go ('\n', eofHack str) para in {-trace (show toks)-} toks
-  where go inp@(_,str) sc =
-	  case alexScan inp sc of
-		AlexEOF -> []
-		AlexError _ -> error "lexical error"
-		AlexSkip  inp' len     -> go inp' sc
-		AlexToken inp' len act -> act (take len str) sc (\sc -> go inp' sc)
-
--- NB. we add a final \n to the string, (see comment in the beginning of line
--- production above).
-eofHack str = str++"\n"
-
-andBegin  :: Action -> StartCode -> Action
-andBegin act new_sc = \str sc cont -> act str new_sc cont
-
-token :: Token -> Action
-token t = \str sc cont -> t : cont sc
-
-strtoken :: (String -> Token) -> Action
-strtoken t = \str sc cont -> t str : cont sc
-
-begin :: StartCode -> Action
-begin sc = \str _ cont -> cont sc
-
--- -----------------------------------------------------------------------------
--- Lex a string as a Haskell identifier
-
-ident :: Action
-ident str sc cont = 
-  case strToHsQNames id of
-	Just names -> TokIdent names : cont sc
-	Nothing -> TokString str : cont sc
- where id = init (tail str)
-
-strToHsQNames :: String -> Maybe [HsQName]
-strToHsQNames str0
- = case lexer (\t -> returnP t) str0 (SrcLoc 1 1 "") 1 1 "" [] of
-	Ok _ (VarId str)
-	   -> Just [ UnQual (HsVarName (HsIdent str)) ]
-        Ok _ (QVarId (mod0,str))
- 	   -> Just [ Qual (Module mod0) (HsVarName (HsIdent str)) ]
-	Ok _ (ConId str)
-	   -> Just [ UnQual (HsTyClsName (HsIdent str)),
-		     UnQual (HsVarName (HsIdent str)) ]
-        Ok _ (QConId (mod0,str))
-	   -> Just [ Qual (Module mod0) (HsTyClsName (HsIdent str)),
-		     Qual (Module mod0) (HsVarName (HsIdent str)) ]
-        Ok _ (VarSym str)
-	   -> Just [ UnQual (HsVarName (HsSymbol str)) ]
-        Ok _ (ConSym str)
-	   -> Just [ UnQual (HsTyClsName (HsSymbol str)),
-		     UnQual (HsVarName (HsSymbol str)) ]
-        Ok _ (QVarSym (mod0,str))
-	   -> Just [ Qual (Module mod0) (HsVarName (HsSymbol str)) ]
-        Ok _ (QConSym (mod0,str))
-	   -> Just [ Qual (Module mod0) (HsTyClsName (HsSymbol str)),
-		     Qual (Module mod0) (HsVarName (HsSymbol str)) ]
-	_other
-	   -> Nothing
-}
diff --git a/src/HaddockModuleTree.hs b/src/HaddockModuleTree.hs
index bd877bf4..51c0fa17 100644
--- a/src/HaddockModuleTree.hs
+++ b/src/HaddockModuleTree.hs
@@ -1,6 +1,6 @@
 module HaddockModuleTree(ModuleTree(..), mkModuleTree) where
 
-import HsSyn
+import HsSyn2
 
 data ModuleTree = Node String Bool (Maybe String) (Maybe Doc) [ModuleTree]
 
diff --git a/src/HaddockParse.y b/src/HaddockParse.y
deleted file mode 100644
index dbc97446..00000000
--- a/src/HaddockParse.y
+++ /dev/null
@@ -1,96 +0,0 @@
-{
-module HaddockParse (parseParas, parseString) where
-
-import HaddockLex
-import HsSyn
-}
-
-%tokentype { Token }
-
-%token	'/'	{ TokSpecial '/' }
-	'@'	{ TokSpecial '@' }
-	'['     { TokDefStart }
-	']'     { TokDefEnd }
-	DQUO 	{ TokSpecial '\"' }
-	URL	{ TokURL $$ }
-	ANAME	{ TokAName $$ }
-	'-'	{ TokBullet }
-	'(n)'	{ TokNumber }
-	'>..'	{ TokBirdTrack $$ }
-	IDENT   { TokIdent $$ }
-	PARA    { TokPara }
-	STRING	{ TokString $$ }
-
-%monad { Either String }
-
-%name parseParas  doc
-%name parseString seq
-
-%%
-
-doc	:: { Doc }
-	: apara PARA doc	{ docAppend $1 $3 }
-	| PARA doc 		{ $2 }
-	| apara			{ $1 }
-	| {- empty -}		{ DocEmpty }
-
-apara	:: { Doc }
-	: ulpara		{ DocUnorderedList [$1] }
-	| olpara		{ DocOrderedList [$1] }
-        | defpara               { DocDefList [$1] }
-	| para			{ $1 }
-
-ulpara  :: { Doc }
-	: '-' para		{ $2 }
-
-olpara  :: { Doc } 
-	: '(n)' para		{ $2 }
-
-defpara :: { (Doc,Doc) }
-	: '[' seq ']' seq	{ ($2, $4) }
-
-para    :: { Doc }
-	: seq			{ docParagraph $1 }
-	| codepara		{ DocCodeBlock $1 }
-
-codepara :: { Doc }
-	: '>..' codepara	{ docAppend (DocString $1) $2 }
-	| '>..'			{ DocString $1 }
-
-seq	:: { Doc }
-	: elem seq		{ docAppend $1 $2 }
-	| elem			{ $1 }
-
-elem	:: { Doc }
-	: elem1			{ $1 }
-	| '@' seq1 '@'		{ DocMonospaced $2 }
-
-seq1	:: { Doc }
-	: elem1 seq1		{ docAppend $1 $2 }
-	| elem1			{ $1 }
-
-elem1	:: { Doc }
-	: STRING		{ DocString $1 }
-	| '/' strings '/'	{ DocEmphasis (DocString $2) }
-	| URL			{ DocURL $1 }
-	| ANAME			{ DocAName $1 }
-	| IDENT			{ DocIdentifier $1 }
-	| DQUO strings DQUO	{ DocModule $2 }
-
-strings  :: { String }
-	: STRING		{ $1 }
-	| STRING strings	{ $1 ++ $2 }
-
-{
-happyError :: [Token] -> Either String a
-happyError toks = 
-  Left ("parse error in doc string: "  ++ show (take 3 toks))
-
--- Either monad (we can't use MonadError because GHC < 5.00 has
--- an older incompatible version).
-instance Monad (Either String) where
-	return        = Right
-	Left  l >>= _ = Left l
-	Right r >>= k = k r
-	fail msg      = Left msg
-}
diff --git a/src/HaddockRename.hs b/src/HaddockRename.hs
index aff9fbcd..d3667d6b 100644
--- a/src/HaddockRename.hs
+++ b/src/HaddockRename.hs
@@ -15,7 +15,7 @@ module HaddockRename (
 
 import HaddockTypes
 import HaddockUtil	( unQual )
-import HsSyn
+import HsSyn2
 import Map ( Map )
 import qualified Map hiding ( Map )
 
diff --git a/src/HaddockTypes.hs b/src/HaddockTypes.hs
index 990d2408..e81bf11d 100644
--- a/src/HaddockTypes.hs
+++ b/src/HaddockTypes.hs
@@ -12,8 +12,11 @@ module HaddockTypes (
   DocOption(..), InstHead,
  ) where
 
-import HsSyn
-import Map
+import HsSyn2
+
+import qualified GHC as GHC
+
+import Data.Map
 
 -- ---------------------------------------------------------------------------
 -- Describing a module interface
@@ -84,8 +87,8 @@ data DocOption
 
 data ExportItem 
   = ExportDecl
-	HsQName		-- the original name
-	HsDecl		-- a declaration (with doc annotations)
+	GHC.Name	-- the original name
+	GHC.HsDecl	-- a declaration (with doc annotations)
 	[InstHead]	-- instances relevant to this declaration
 
   | ExportNoDecl	-- an exported entity for which we have no documentation
@@ -105,6 +108,13 @@ data ExportItem
   | ExportModule	-- a cross-reference to another module
 	Module
 
+type InstHead = (HsContext,HsAsst)
+
 type ModuleMap = Map Module Interface
+type ModuleMap2 = Map GHC.Module HaddockModule
 
-type InstHead = (HsContext,HsAsst)
+data HaddockModule = HM {
+  hmod_options      :: [DocOption],
+  hmod_decls        :: Map Name GHC.HsDecl,
+  hmod_orig_exports :: [ExportItem]
+}
diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs
index 0c458049..d4c495a3 100644
--- a/src/HaddockUtil.hs
+++ b/src/HaddockUtil.hs
@@ -25,11 +25,11 @@ module HaddockUtil (
   html_xrefs_ref,
  ) where
 
-import Binary
-import HaddockLex
-import HaddockParse
+import Binary2
+import HaddockLex2
+import HaddockParse2
 import HaddockTypes
-import HsSyn
+import HsSyn2
 import Map ( Map )
 import qualified Map hiding ( Map )
 
@@ -142,6 +142,42 @@ addConDocs (x:xs) doc = addConDoc x doc : xs
 -- ---------------------------------------------------------------------------
 -- Making abstract declarations
 
+restrictTo :: [GHC.Name] -> (GHC.HsDecl GHC.Name) -> (GHC.HsDecl GHC.Name)
+restrictTo names decl = case decl of
+  TyClD d | isDataDecl d && tcdND d == DataType -> 
+    TyClD (d { tcdCons = restrictCons names (tcdCons d) }
+  TyClD d | isDataDecl d && tcdND d == NewType -> 
+   case restrictCons names (tcdCons d) of
+      []    -> TyClD (d { tcdND = DataType, tcdCons = [] })
+      [con] -> TyClD (d { tcdCons = con })
+  TyClD d | isClassDecl d -> 
+    TyClD (d { tcdSigs = restrictDecls names (tcdSigs d) })   
+  _ -> decl
+   
+restrictCons :: [GHC.Name] -> [GHC.LConDecl GHC.Name] -> [GHC.LConDecl GHC.Name]
+restrictCons names decls = [ d | Just d <- map keep decls ]  
+  where keep d | con_name (unLoc d) `elem` names = 
+          case con_details d of
+            PrefixCon _ -> Just d
+            RecCon fields 
+              | all field_avail fields -> Just d
+              | otherwise = Just (d { con_details = PrefixCon field_types })
+       		-- if we have *all* the field names available, then
+		-- keep the record declaration.  Otherwise degrade to
+		-- a constructor declaration.  This isn't quite right, but
+		-- it's the best we can do.
+	   where
+            field_avail (HsRecField n _ _) = (unLoc n) `elem` names
+            field_types = [ ty | HsRecField n ty _ <- fields] 
+        keep d | otherwise = Nothing
+
+restrictDecls :: [GHC.Name] -> [GHC.LSig GHC.Name] -> [GHC.LSig GHC.Name]
+restrictDecls names decls = filter keep decls
+  where keep d = sigName d `elem` names
+        
+	-- ToDo: not really correct
+
+{-
 restrictTo :: [HsName] -> HsDecl -> HsDecl
 restrictTo names decl = case decl of
      HsDataDecl loc ctxt n xs cons drv doc -> 
@@ -177,7 +213,7 @@ restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
 restrictDecls names decls = filter keep decls
   where keep d = not (null (declBinders d `intersect` names))
 	-- ToDo: not really correct
-
+-}
 -- -----------------------------------------------------------------------------
 -- Extract documentation from a declaration
 
diff --git a/src/HsLexer.lhs b/src/HsLexer.lhs
index d7cd62a6..93baa6aa 100644
--- a/src/HsLexer.lhs
+++ b/src/HsLexer.lhs
@@ -17,7 +17,7 @@ module HsLexer (Token(..), lexer, parseError,isSymbol) where
 
 import HsParseMonad
 import HsParseUtils
-import HsSyn
+import HsSyn2
 
 import Numeric	( readHex, readOct )
 import Char
diff --git a/src/HsParseMonad.lhs b/src/HsParseMonad.lhs
index f1423f6f..27032c37 100644
--- a/src/HsParseMonad.lhs
+++ b/src/HsParseMonad.lhs
@@ -10,7 +10,7 @@
 \begin{code}
 module HsParseMonad where
 
-import HsSyn
+import HsSyn2
 \end{code}
 
 \begin{code}
diff --git a/src/HsParseUtils.lhs b/src/HsParseUtils.lhs
index 58f7f763..29999588 100644
--- a/src/HsParseUtils.lhs
+++ b/src/HsParseUtils.lhs
@@ -33,7 +33,7 @@ module HsParseUtils (
 	, toTyClsHsName		-- HsName -> HsName
  ) where
 
-import HsSyn
+import HsSyn2
 import HsParseMonad
 
 import Char(isDigit,isOctDigit,isHexDigit,digitToInt)
diff --git a/src/HsParser.ly b/src/HsParser.ly
index b62f1cae..c3edd3ce 100644
--- a/src/HsParser.ly
+++ b/src/HsParser.ly
@@ -17,12 +17,12 @@ ToDo: Differentiate between record updates and labeled construction.
 > module HsParser (parse) where
 > 
 > import Monad
-> import HsSyn
+> import HsSyn2
 > import HsParseMonad
 > import HsLexer
 > import HsParseUtils
-> import HaddockLex 	hiding (Token)
-> import HaddockParse
+> import HaddockLex2 	hiding (Token)
+> import HaddockParse2
 > import HaddockUtil 	hiding (splitTyConApp)
 > import Char 		( isSpace )
 > }
diff --git a/src/HsSyn.lhs b/src/HsSyn.lhs
deleted file mode 100644
index cb5ec11e..00000000
--- a/src/HsSyn.lhs
+++ /dev/null
@@ -1,542 +0,0 @@
-% -----------------------------------------------------------------------------
-% $Id: HsSyn.lhs,v 1.22 2004/08/09 11:55:07 simonmar Exp $
-%
-% (c) The GHC Team, 1997-2002
-%
-% A suite of datatypes describing the abstract syntax of Haskell 98.
-%
-% -----------------------------------------------------------------------------
-
-\begin{code}
-module HsSyn (
-    SrcLoc(..), Module(..), HsQName(..), HsName(..), HsIdentifier(..),
-    HsModule(..), HsExportSpec(..),  ModuleInfo(..),
-    HsImportDecl(..), HsImportSpec(..), HsAssoc(..),
-    HsDecl(..), HsMatch(..), HsConDecl(..), HsFieldDecl(..), 
-    HsBangType(..), HsRhs(..),
-    HsGuardedRhs(..), HsType(..), HsContext, HsAsst, HsIPContext, HsCtxt(..),
-    HsLiteral(..), HsExp(..), HsPat(..), HsPatField(..), HsStmt(..),
-    HsFieldUpdate(..), HsAlt(..), HsGuardedAlts(..), HsGuardedAlt(..),
-    HsCallConv(..), HsFISafety(..), HsFunDep,
-
-    mkHsForAllType,
-
-    prelude_mod, main_mod, 
-    unit_con_name, tuple_con_name, nil_con_name,
-    as_name, qualified_name, hiding_name, minus_name, pling_name, dot_name,
-    forall_name, unsafe_name, safe_name, threadsafe_name, export_name,
-    stdcall_name, ccall_name, dotnet_name,
-    unit_tycon_name, fun_tycon_name, list_tycon_name, tuple_tycon_name,
-    unit_tycon_qname, fun_tycon_qname, list_tycon_qname, tuple_tycon_qname,
-    unit_tycon, fun_tycon, list_tycon, tuple_tycon,
-
-    emptyModuleInfo,
-
-    hsIdentifierStr, hsAnchorNameStr, hsNameStr, 
-	
-    GenDoc(..), Doc, DocMarkup(..),
-    markup, mapIdent, idMarkup,
-    docAppend, docParagraph,
-  ) where
-
-import Char (isSpace)
-
-data SrcLoc = SrcLoc !Int !Int FilePath -- (Line, Indentation, FileName)
-  deriving (Eq,Ord,Show)
-
-newtype Module = Module String
-  deriving (Eq,Ord)
-
-instance Show Module where
-   showsPrec _ (Module m) = showString m
-
-data HsQName
-	= Qual Module HsName
-	| UnQual HsName
-  deriving (Eq,Ord)
-
-instance Show HsQName where
-   showsPrec _ (Qual (Module m) s) = 
-	showString m . showString "." . shows s
-   showsPrec _ (UnQual s) = shows s
-
-data HsName 
-	= HsTyClsName HsIdentifier
-	| HsVarName HsIdentifier
-  deriving (Eq,Ord)
-
-instance Show HsName where
-   showsPrec p (HsTyClsName i) = showsPrec p i
-   showsPrec p (HsVarName i)   = showsPrec p i
-
-data HsIdentifier
-	= HsIdent   String
-	| HsSymbol  String
-	| HsSpecial String
-  deriving (Eq,Ord)
-
-instance Show HsIdentifier where
-   showsPrec _ (HsIdent s) = showString s
-   showsPrec _ (HsSymbol s) = showString s
-   showsPrec _ (HsSpecial s) = showString s
-
-data HsModule = HsModule SrcLoc Module (Maybe [HsExportSpec])
-                        [HsImportDecl] [HsDecl] 
-			(Maybe String)		-- the doc options
-			ModuleInfo      	-- the info (portability etc.)
-                        (Maybe Doc)             -- the module doc.
-  deriving Show
-
-data ModuleInfo = ModuleInfo
-	{ description :: Maybe Doc,
-          portability :: Maybe String,
-	  stability   :: Maybe String,
-	  maintainer  :: Maybe String
-          }
-  deriving Show
-
-emptyModuleInfo :: ModuleInfo
-emptyModuleInfo = ModuleInfo {
-   description = Nothing,
-   portability = Nothing,
-   stability = Nothing,
-   maintainer = Nothing
-   }
-
--- Export/Import Specifications
-
-data HsExportSpec
-	 = HsEVar HsQName			-- variable
-	 | HsEAbs HsQName			-- T
-	 | HsEThingAll HsQName			-- T(..)
-	 | HsEThingWith HsQName [HsQName]	-- T(C_1,...,C_n)
-	 | HsEModuleContents Module		-- module M   (not for imports)
-	 | HsEGroup Int Doc			-- a doc section heading
-	 | HsEDoc Doc				-- some documentation
-	 | HsEDocNamed String			-- a reference to named doc
-  deriving (Eq,Show)
-
-data HsImportDecl
-	 = HsImportDecl SrcLoc Module Bool (Maybe Module)
-	                (Maybe (Bool,[HsImportSpec]))
-  deriving (Eq,Show)
-
-data HsImportSpec
-	 = HsIVar HsName			-- variable
-	 | HsIAbs HsName			-- T
-	 | HsIThingAll HsName		-- T(..)
-	 | HsIThingWith HsName [HsName]	-- T(C_1,...,C_n)
-  deriving (Eq,Show)
-
-data HsAssoc
-	 = HsAssocNone
-	 | HsAssocLeft
-	 | HsAssocRight
-  deriving (Eq,Show)
-
-data HsFISafety
- 	= HsFIUnsafe
-	| HsFISafe
-	| HsFIThreadSafe
-  deriving (Eq,Show)
-
-data HsCallConv
-	= HsCCall
-	| HsStdCall
-	| HsDotNetCall
-  deriving (Eq,Show)
-
-data HsDecl
-  = HsTypeDecl SrcLoc HsName [HsName] HsType (Maybe Doc)
- 
-  | HsDataDecl SrcLoc HsContext HsName [HsName] [HsConDecl] [HsQName]
- 		  (Maybe Doc)
- 
-  | HsInfixDecl SrcLoc HsAssoc Int [HsName]
- 
-  | HsNewTypeDecl SrcLoc HsContext HsName [HsName] HsConDecl [HsQName]
- 		  (Maybe Doc)
- 
-  | HsClassDecl SrcLoc HsContext HsName [HsName] [HsFunDep] [HsDecl] (Maybe Doc)
- 
-  | HsInstDecl SrcLoc HsContext HsAsst [HsDecl]
- 
-  | HsDefaultDecl SrcLoc [HsType]
- 
-  | HsTypeSig SrcLoc [HsName] HsType (Maybe Doc)
- 
-  | HsFunBind [HsMatch]
- 
-  | HsPatBind SrcLoc HsPat HsRhs {-where-} [HsDecl]
- 
-  | HsForeignImport SrcLoc HsCallConv HsFISafety String HsName HsType
- 		    (Maybe Doc)
- 
-  | HsForeignExport SrcLoc HsCallConv String HsName HsType
- 
-  | HsDocCommentNext  SrcLoc Doc	-- a documentation annotation
-  | HsDocCommentPrev  SrcLoc Doc	-- a documentation annotation
-  | HsDocCommentNamed SrcLoc String Doc	-- a documentation annotation
-  | HsDocGroup        SrcLoc Int Doc	-- a documentation group
-  deriving (Eq,Show)
-
-data HsMatch 
-	 = HsMatch SrcLoc HsQName [HsPat] HsRhs {-where-} [HsDecl]
-  deriving (Eq,Show)
-
-data HsConDecl
-     = HsConDecl SrcLoc HsName [HsName] HsContext [HsBangType] (Maybe Doc)
-     | HsRecDecl SrcLoc HsName [HsName] HsContext [HsFieldDecl] (Maybe Doc)
-  deriving (Eq,Show)
-
-data HsFieldDecl
-	= HsFieldDecl [HsName] HsBangType (Maybe Doc)
-  deriving (Eq,Show)
-
-data HsBangType
-	 = HsBangedTy   HsType
-	 | HsUnBangedTy HsType
-  deriving (Eq,Show)
-
-data HsRhs
-	 = HsUnGuardedRhs HsExp
-	 | HsGuardedRhss  [HsGuardedRhs]
-  deriving (Eq,Show)
-
-data HsGuardedRhs
-	 = HsGuardedRhs SrcLoc [HsStmt] HsExp
-  deriving (Eq,Show)
-
-data HsType
-	 = HsForAllType (Maybe [HsName]) HsIPContext HsType
-	 | HsTyFun   HsType HsType
-	 | HsTyTuple Bool{-boxed-} [HsType]
-	 | HsTyApp   HsType HsType
-	 | HsTyVar   HsName
-	 | HsTyCon   HsQName
-	 | HsTyDoc   HsType Doc
-	 | HsTyIP    HsName HsType
-  deriving (Eq,Show)
-
-type HsFunDep    = ([HsName], [HsName])
-type HsContext   = [HsAsst]
-type HsIPContext = [HsCtxt]
-
-data HsCtxt
- = HsAssump HsAsst	-- for multi-parameter type classes
- | HsIP     HsName HsType
-  deriving (Eq,Show)
-
-type HsAsst = (HsQName,[HsType])
-
-data HsLiteral
-	= HsInt		Integer
-	| HsChar	Char
-	| HsString	String
-	| HsFrac	Rational
-	-- GHC unboxed literals:
-	| HsCharPrim	Char
-	| HsStringPrim	String
-	| HsIntPrim	Integer
-	| HsFloatPrim	Rational
-	| HsDoublePrim	Rational
-  deriving (Eq, Show)
-
-data HsExp
-	= HsIPVar HsQName
-	| HsVar HsQName
-	| HsCon HsQName
-	| HsLit HsLiteral
-	| HsInfixApp HsExp HsExp HsExp
-	| HsApp HsExp HsExp
-	| HsNegApp HsExp
-	| HsLambda [HsPat] HsExp
-	| HsLet [HsDecl] HsExp
-	| HsIf HsExp HsExp HsExp
-	| HsCase HsExp [HsAlt]
-	| HsDo [HsStmt]
-	| HsTuple Bool{-boxed-} [HsExp]
-	| HsList [HsExp]
-	| HsParen HsExp
-	| HsLeftSection HsExp HsExp
-	| HsRightSection HsExp HsExp
-	| HsRecConstr HsQName [HsFieldUpdate]
-	| HsRecUpdate HsExp [HsFieldUpdate]
-	| HsEnumFrom HsExp
-	| HsEnumFromTo HsExp HsExp
-	| HsEnumFromThen HsExp HsExp
-	| HsEnumFromThenTo HsExp HsExp HsExp
-	| HsListComp HsExp [HsStmt]
-	| HsExpTypeSig SrcLoc HsExp HsType
-	| HsAsPat HsName HsExp		-- pattern only
-	| HsWildCard			-- ditto
-	| HsIrrPat HsExp		-- ditto
-	-- HsCCall                         (ghc extension)
-	-- HsSCC			   (ghc extension)
- deriving (Eq,Show)
-
-data HsPat
-	= HsPVar HsName
-	| HsPLit HsLiteral
-	| HsPNeg HsPat
-	| HsPInfixApp HsPat HsQName HsPat
-	| HsPApp HsQName [HsPat]
-	| HsPTuple Bool{-boxed-} [HsPat]
-	| HsPList [HsPat]
-	| HsPParen HsPat
-	| HsPRec HsQName [HsPatField]
-	| HsPAsPat HsName HsPat
-	| HsPWildCard
-	| HsPIrrPat HsPat
-	| HsPTypeSig HsPat HsType
- deriving (Eq,Show)
-
-data HsPatField
-	= HsPFieldPat HsQName HsPat
- deriving (Eq,Show)
-
-data HsStmt
-	= HsGenerator HsPat HsExp
-	| HsParStmt [HsStmt]
-	| HsQualifier HsExp
-	| HsLetStmt [HsDecl]
- deriving (Eq,Show)
-
-data HsFieldUpdate
-	= HsFieldUpdate HsQName HsExp
-  deriving (Eq,Show)
-
-data HsAlt
-	= HsAlt SrcLoc HsPat HsGuardedAlts [HsDecl]
-  deriving (Eq,Show)
-
-data HsGuardedAlts
-	= HsUnGuardedAlt HsExp
-	| HsGuardedAlts  [HsGuardedAlt]
-  deriving (Eq,Show)
-
-data HsGuardedAlt
-	= HsGuardedAlt SrcLoc [HsStmt] HsExp
-  deriving (Eq,Show)
-
------------------------------------------------------------------------------
--- Smart constructors
-
--- pinched from GHC
-mkHsForAllType :: Maybe [HsName] -> HsIPContext -> HsType -> HsType
-mkHsForAllType (Just []) [] ty = ty	-- Explicit for-all with no tyvars
-mkHsForAllType mtvs1     [] (HsForAllType mtvs2 ctxt ty)
- = mkHsForAllType (mtvs1 `plus` mtvs2) ctxt ty
- where
-    mtvs        `plus` Nothing     = mtvs
-    Nothing     `plus` mtvs        = mtvs
-    (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
-mkHsForAllType tvs ctxt ty = HsForAllType tvs ctxt ty
-
------------------------------------------------------------------------------
--- Builtin names.
-
-prelude_mod, main_mod :: Module
-prelude_mod	      = Module "Prelude"
-main_mod	      = Module "Main"
-
-unit_ident, nil_ident :: HsIdentifier
-unit_ident	      = HsSpecial "()"
-nil_ident	      = HsSpecial "[]"
-
-tuple_ident :: Int -> HsIdentifier
-tuple_ident i	      = HsSpecial ("("++replicate i ','++")")
-
-unit_con_name, nil_con_name :: HsQName
-unit_con_name	      = Qual prelude_mod (HsVarName unit_ident)
-nil_con_name	      = Qual prelude_mod (HsVarName nil_ident)
-
-tuple_con_name :: Int -> HsQName
-tuple_con_name i      = Qual prelude_mod (HsVarName (tuple_ident i))
-
-as_name, qualified_name, hiding_name, unsafe_name, safe_name
-       , forall_name, threadsafe_name, export_name, ccall_name, stdcall_name
-       , dotnet_name, minus_name, pling_name, dot_name :: HsName
-
-as_name	              = HsVarName (HsIdent "as")
-qualified_name        = HsVarName (HsIdent "qualified")
-hiding_name	      = HsVarName (HsIdent "hiding")
-unsafe_name	      = HsVarName (HsIdent "unsafe")
-safe_name	      = HsVarName (HsIdent "safe")
-forall_name	      = HsVarName (HsIdent "forall")
-threadsafe_name	      = HsVarName (HsIdent "threadsafe")
-export_name	      = HsVarName (HsIdent "export")
-ccall_name	      = HsVarName (HsIdent "ccall")
-stdcall_name	      = HsVarName (HsIdent "stdcall")
-dotnet_name	      = HsVarName (HsIdent "dotnet")
-minus_name	      = HsVarName (HsSymbol "-")
-pling_name	      = HsVarName (HsSymbol "!")
-dot_name	      = HsVarName (HsSymbol ".")
-
-unit_tycon_name, fun_tycon_name, list_tycon_name :: HsName
-
-unit_tycon_name       = HsTyClsName unit_ident
-fun_tycon_name        = HsTyClsName (HsSpecial "->")
-list_tycon_name       = HsTyClsName (HsSpecial "[]")
-
-tuple_tycon_name :: Int -> HsName
-tuple_tycon_name i    = HsTyClsName (tuple_ident i)
-
-unit_tycon_qname, fun_tycon_qname, list_tycon_qname :: HsQName
-
-unit_tycon_qname      = Qual prelude_mod unit_tycon_name   
-fun_tycon_qname       = Qual prelude_mod fun_tycon_name    
-list_tycon_qname      = Qual prelude_mod list_tycon_name   
-
-tuple_tycon_qname :: Int -> HsQName
-tuple_tycon_qname i   = Qual prelude_mod (tuple_tycon_name i)
-
-unit_tycon, fun_tycon, list_tycon :: HsType
-
-unit_tycon	      = HsTyCon unit_tycon_qname
-fun_tycon	      = HsTyCon fun_tycon_qname
-list_tycon	      = HsTyCon list_tycon_qname
-
-tuple_tycon :: Int -> HsType
-tuple_tycon i	      = HsTyCon (tuple_tycon_qname i)
-
-hsIdentifierStr :: HsIdentifier -> String
-hsIdentifierStr (HsIdent str)   =  str
-hsIdentifierStr (HsSymbol str)  =  str
-hsIdentifierStr (HsSpecial str) =  str
-
-hsAnchorNameStr :: HsName -> String
-hsAnchorNameStr (HsTyClsName id0) = "t:" ++ hsIdentifierStr id0
-hsAnchorNameStr (HsVarName id0)   = "v:" ++ hsIdentifierStr id0
-
-hsNameStr :: HsName -> String
-hsNameStr (HsTyClsName id0) = hsIdentifierStr id0
-hsNameStr (HsVarName id0)   = hsIdentifierStr id0
-
--- -----------------------------------------------------------------------------
--- Doc strings and formatting
-
-data GenDoc id
-  = DocEmpty 
-  | DocAppend (GenDoc id) (GenDoc id)
-  | DocString String
-  | DocParagraph (GenDoc id)
-  | DocIdentifier id
-  | DocModule String
-  | DocEmphasis (GenDoc id)
-  | DocMonospaced (GenDoc id)
-  | DocUnorderedList [GenDoc id]
-  | DocOrderedList [GenDoc id]
-  | DocDefList [(GenDoc id, GenDoc id)]
-  | DocCodeBlock (GenDoc id)
-  | DocURL String
-  | DocAName String
-  deriving (Eq, Show)
-
-type Doc = GenDoc [HsQName]
-
--- | DocMarkup is a set of instructions for marking up documentation.
--- In fact, it's really just a mapping from 'GenDoc' to some other
--- type [a], where [a] is usually the type of the output (HTML, say).
-
-data DocMarkup id a = Markup {
-  markupEmpty         :: a,
-  markupString        :: String -> a,
-  markupParagraph     :: a -> a,
-  markupAppend        :: a -> a -> a,
-  markupIdentifier    :: id -> a,
-  markupModule        :: String -> a,
-  markupEmphasis      :: a -> a,
-  markupMonospaced    :: a -> a,
-  markupUnorderedList :: [a] -> a,
-  markupOrderedList   :: [a] -> a,
-  markupDefList       :: [(a,a)] -> a,
-  markupCodeBlock     :: a -> a,
-  markupURL	      :: String -> a,
-  markupAName	      :: String -> a
-  }
-
-markup :: DocMarkup id a -> GenDoc id -> a
-markup m DocEmpty		= markupEmpty m
-markup m (DocAppend d1 d2)	= markupAppend m (markup m d1) (markup m d2)
-markup m (DocString s)		= markupString m s
-markup m (DocParagraph d)	= markupParagraph m (markup m d)
-markup m (DocIdentifier i)	= markupIdentifier m i
-markup m (DocModule mod0)	= markupModule m mod0
-markup m (DocEmphasis d)	= markupEmphasis m (markup m d)
-markup m (DocMonospaced d)	= markupMonospaced m (markup m d)
-markup m (DocUnorderedList ds)	= markupUnorderedList m (map (markup m) ds)
-markup m (DocOrderedList ds)	= markupOrderedList m (map (markup m) ds)
-markup m (DocDefList ds)        = markupDefList m (map (markupPair m) ds)
-markup m (DocCodeBlock d)	= markupCodeBlock m (markup m d)
-markup m (DocURL url)		= markupURL m url
-markup m (DocAName ref)		= markupAName m ref
-
-markupPair :: DocMarkup id a -> (GenDoc id, GenDoc id) -> (a, a)
-markupPair m (a,b) = (markup m a, markup m b)
-
--- | The identity markup
-idMarkup :: DocMarkup a (GenDoc a)
-idMarkup = Markup {
-  markupEmpty         = DocEmpty,
-  markupString        = DocString,
-  markupParagraph     = DocParagraph,
-  markupAppend        = DocAppend,
-  markupIdentifier    = DocIdentifier,
-  markupModule        = DocModule,
-  markupEmphasis      = DocEmphasis,
-  markupMonospaced    = DocMonospaced,
-  markupUnorderedList = DocUnorderedList,
-  markupOrderedList   = DocOrderedList,
-  markupDefList       = DocDefList,
-  markupCodeBlock     = DocCodeBlock,
-  markupURL	      = DocURL,
-  markupAName	      = DocAName
-  }
-
--- | Since marking up is just a matter of mapping 'Doc' into some
--- other type, we can \'rename\' documentation by marking up 'Doc' into
--- the same thing, modifying only the identifiers embedded in it.
-mapIdent :: (a -> GenDoc b) -> DocMarkup a (GenDoc b)
-mapIdent f = idMarkup{ markupIdentifier = f }
-
--- -----------------------------------------------------------------------------
--- ** Smart constructors
-
--- used to make parsing easier; we group the list items later
-docAppend :: Doc -> Doc -> Doc
-docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) 
-  = DocUnorderedList (ds1++ds2)
-docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
-  = DocAppend (DocUnorderedList (ds1++ds2)) d
-docAppend (DocOrderedList ds1) (DocOrderedList ds2) 
-  = DocOrderedList (ds1++ds2)
-docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
-  = DocAppend (DocOrderedList (ds1++ds2)) d
-docAppend (DocDefList ds1) (DocDefList ds2)
-  = DocDefList (ds1++ds2)
-docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d)
-  = DocAppend (DocDefList (ds1++ds2)) d
-docAppend DocEmpty d = d
-docAppend d DocEmpty = d
-docAppend d1 d2 
-  = DocAppend d1 d2
-
--- again to make parsing easier - we spot a paragraph whose only item
--- is a DocMonospaced and make it into a DocCodeBlock
-docParagraph :: Doc -> Doc
-docParagraph (DocMonospaced p)
-  = DocCodeBlock p
-docParagraph (DocAppend (DocString s1) (DocMonospaced p))
-  | all isSpace s1
-  = DocCodeBlock p
-docParagraph (DocAppend (DocString s1)
-		(DocAppend (DocMonospaced p) (DocString s2)))
-  | all isSpace s1 && all isSpace s2
-  = DocCodeBlock p
-docParagraph (DocAppend (DocMonospaced p) (DocString s2))
-  | all isSpace s2
-  = DocCodeBlock p
-docParagraph p
-  = DocParagraph p
-\end{code}
diff --git a/src/Main.hs b/src/Main.hs
index b2ea7709..dfc5ee99 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,24 +7,19 @@
 
 module Main (main) where
 
-import Binary
-import Digraph
---import HaddockDB   -- not compiling
+import HsSyn2
 import HaddockHtml
 import HaddockHoogle
-import HaddockLex
-import HaddockParse
 import HaddockRename
 import HaddockTypes
 import HaddockUtil
 import HaddockVersion
-import HsParseMonad
-import HsParser
-import HsSyn
-import Map ( Map )
-import qualified Map hiding ( Map )
 import Set
 import Paths_haddock	( getDataDir )
+import Binary2
+import Digraph2
+import HsParser
+import HsParseMonad
 
 import Control.Exception ( bracket )
 import Control.Monad ( when )
@@ -41,6 +36,10 @@ import System.IO ( stderr, IOMode(..), openFile, hClose, hGetContents, hPutStrLn
 import Foreign
 import Foreign.C
 #endif
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.Maybe
+
 
 #if __GLASGOW_HASKELL__ >= 603
 import System.Process
@@ -51,6 +50,10 @@ import System.Directory		( doesDirectoryExist, doesFileExist )
 import Control.Concurrent
 #endif
 
+import qualified GHC as GHC
+import Outputable
+import SrcLoc
+
 -----------------------------------------------------------------------------
 -- Top-level stuff
 main :: IO ()
@@ -96,6 +99,7 @@ data Flag
   | Flag_IgnoreAllExports
   | Flag_HideModule String
   | Flag_UsePackage String
+  | Flag_GHCFlag String   
   deriving (Eq)
 
 options :: Bool -> [OptDescr Flag]
@@ -161,17 +165,21 @@ options backwardsCompat =
     Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
 	"behave as if MODULE has the hide attribute",
     Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE")
-	"the modules being processed depend on PACKAGE"
+	"the modules being processed depend on PACKAGE",
+    Option [] ["ghc-flag"] (ReqArg Flag_GHCFlag "FLAG")
+	"send a one-word FLAG to the Glasgow Haskell Compiler"
   ]
 
 run :: [Flag] -> [FilePath] -> IO ()
 run flags files = do
-  when (Flag_Help `elem` flags) $ do
+  
+  whenFlag Flag_Help $ do
      prog <- getProgramName
      bye (usageInfo (usageHeader prog) (options False))
 
-  when (Flag_Version `elem` flags) $
-     bye ("Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2003\n")
+  whenFlag Flag_Version $
+     bye ("Haddock version " ++ projectVersion ++ 
+          ", (c) Simon Marlow 2003; port to GHC-api by David Waern 2006\n")
 
   let title = case [str | Flag_Heading str <- flags] of
 		[] -> ""
@@ -249,12 +257,12 @@ run flags files = do
 	&& Flag_Html `elem` flags) $
 	die ("-h cannot be used with --gen-index or --gen-contents")
 
-  when (Flag_GenContents `elem` flags) $ do
+{-  when (Flag_GenContents `elem` flags) $ do
 	ppHtmlContents odir title package maybe_html_help_format
             maybe_index_url maybe_source_urls maybe_wiki_urls
             visible_read_ifaces prologue
         copyHtmlBits odir libdir css_file
-
+-}
   when (Flag_GenIndex `elem` flags) $ do
 	ppHtmlIndex odir title package maybe_html_help_format
             maybe_contents_url maybe_source_urls maybe_wiki_urls
@@ -264,7 +272,41 @@ run flags files = do
   when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do
     ppHtmlHelpFiles title package visible_read_ifaces odir maybe_html_help_format pkg_paths
 
-  parsed_mods <- mapM parse_file files
+  GHC.init (Just "/home/davve/dev/lib/ghc-6.5.20060608")
+  let ghcMode = GHC.JustTypecheck
+  session <- GHC.newSession ghcMode
+  ghcFlags <- GHC.getSessionDynFlags session
+  ghcFlags' <- GHC.initPackages ghcFlags
+
+  let haddockGhcFlags = [ f | Flag_GHCFlag f <- flags ] 
+  (ghcFlags'', rest) <- GHC.parseDynamicFlags ghcFlags' haddockGhcFlags 
+  when (not (null rest)) (die $ "The following flags are not GHC flags: " ++ pprList rest ++ "\n")
+
+  GHC.defaultErrorHandler ghcFlags'' $ do 
+    GHC.setSessionDynFlags session ghcFlags''
+    targets <- mapM (\s -> GHC.guessTarget s Nothing) files
+    GHC.setTargets session targets
+  
+    -- find out the module names of the targets, and topologically sort those modules
+    maybe_module_graph <- GHC.depanal session [] True
+    module_graph <- case maybe_module_graph of 
+      Just module_graph -> return module_graph 
+      Nothing -> die "Failed to load modules"
+    let sorted_modules = flattenSCC (topSortModuleGraph False module_graph Nothing) 
+    let modules = [ GHC.ms_mod modsum | modsum <- sorted_modules, GHC.ms_hspp_file modsum `elem` files ]
+    mb_checked_modules <- mapM (GHC.checkModule session) modules
+    let checked_modules = catMaybes mb_checked_modules
+   
+{-    let parsed_source = unLoc $ GHC.parsedSource (head checked_modules)
+    printSDoc (ppr parsed_source) defaultUserStyle
+-}
+
+    return ()
+   -- case successFlag of 
+    --  GHC.Succeeded -> bye "Succeeded"
+    --  GHC.Failed -> bye "Could not load all targets"
+
+{-  parsed_mods <- mapM parse_file files
 
   sorted_mod_files <- sortModules (zip parsed_mods files)
 	-- emits an error message if there are recursive modules
@@ -330,7 +372,15 @@ run flags files = do
   -- dump an interface if requested
   case dump_iface of
      Nothing -> return ()
-     Just fn -> dumpInterfaces these_ifaces this_doc_env fn
+     Just fn -> dumpInterfaces these_ifaces this_doc_env fn -}
+  where
+    whenFlag flag action = when (flag `elem` flags) action 
+
+    pprList [] = []
+    pprList [x] = show x
+    pprList (x:xs) = show x ++ ", " ++ pprList xs
+
+--moduleFromFilename filename =  
 
 parseIfaceOption :: String -> (FilePath,FilePath)
 parseIfaceOption s = 
@@ -359,6 +409,7 @@ parse_file file = do
 	        Failed err -> die (file ++ ':':err ++ "\n")
     )
 
+{-
 getPrologue :: [Flag] -> IO (Maybe Doc)
 getPrologue flags
   = case [filename | Flag_Prologue filename <- flags ] of
@@ -369,6 +420,18 @@ getPrologue flags
 		Left err -> dieMsg err
 		Right doc -> return (Just doc)
 	_otherwise -> dieMsg "multiple -p/--prologue options"
+-}
+
+getPrologue :: [Flag] -> IO (Maybe (GHC.HsDoc GHC.RdrName))
+getPrologue flags
+  = case [filename | Flag_Prologue filename <- flags ] of
+	[] -> return Nothing 
+	[filename] -> do
+	   str <- readFile filename
+	   case GHC.parseHaddockComment str of
+		Left err -> dieMsg err
+		Right doc -> return (Just doc)
+	_otherwise -> dieMsg "multiple -p/--prologue options"
 
 -- ---------------------------------------------------------------------------
 -- External packages
@@ -437,7 +500,7 @@ getPackageIfaces flags verbose =
 --
 --   2. Convert all the entity references to "doc names".  These are
 --      the names we want to link to in the documentation.
-
+{-
 mkInterfacePhase1
    :: [Flag]
    -> Bool				-- verbose
@@ -598,6 +661,7 @@ mkInterfacePhase2 verbose iface gbl_doc_env =
 	iface_doc = orig_module_doc } ->
 
    let
+	-- [ The export list from the renamed output (sort of) ]
      exported_visible_names = 
 	[orig | (nm,orig) <- Map.toAscList env, nm `notElem` reexports ]
 
@@ -719,12 +783,113 @@ derivedInstances mdl decl = case decl of
 unknownConstraint :: HsQName
 unknownConstraint = UnQual (HsTyClsName (HsIdent "???"))
 
+-}
 -- -----------------------------------------------------------------------------
 -- Build the list of items that will become the documentation, from the
 -- export list.  At this point, the list of ExportItems is in terms of
 -- original names.
 
 mkExportItems
+        :: ModuleMap2
+	-> GHC.Module			-- this module
+	-> GHC.NameSet			-- exported names (orig)
+	-> Map GHC.Name (GHC.HsDecl GHC.Name)	-- maps local names to declarations
+	-> Map GHC.Name [GHC.Name]	-- sub-map for this module
+	-> [GHC.HsDecl GHC.Name]			-- decls in the current module
+	-> [DocOption]
+	-> Maybe [GHC.IE Name]
+	-> Bool				-- --ignore-all-exports flag
+	-> ErrMsgM [ExportItem]
+
+mkExportItems mod_map this_mod exported_names decl_map sub_map decls
+              opts maybe_exps ignore_all_exports
+  | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts
+    = everything_local_exported
+  | Just specs <- maybe_exps = do 
+      exps <- mapM lookupExport specs
+      return (concat exps)
+  where
+    everything_local_exported =  -- everything exported
+	return (fullContentsOfThisModule this_mod decls)
+
+    lookupExport (GHC.IEVar x)             = declWith x
+    lookupExport (GHC.IEThingAbs t)        = declWith t
+    lookupExport (GHC.IEThingAll t)        = declWith t
+    lookupExport (GHC.IEThingWith t cs)    = declWith t
+    lookupExport (GHC.IEModuleContents m)  = fullContentsOf m
+    lookupExport (GHC.IEGroup lev doc)     = return [ ExportGroup lev "" doc ]
+    lookupExport (GHC.IEDoc doc)           = return [ ExportDoc doc ]
+    lookupExport (GHC.IEDocNamed str)
+	= do r <- findNamedDoc str decls
+	     case r of
+		Nothing -> return []
+		Just found -> return [ ExportDoc found ]
+
+    -- NOTE: I'm unsure about this. Currently only "External" names are considered.	
+    declWith :: GHC.Name -> ErrMsgM [ ExportItem ]
+    declWith t | not (isExternalName t) = return []
+    declWith t
+	| Just decl <- findDecl t
+	= return [ ExportDecl t (restrictTo subs (extractDecl x mdl decl)) [] ]
+	| otherwise
+	= return [ ExportNoDecl t t (map (Qual mdl) subs) ]
+	-- can't find the decl (it might be from another package), but let's
+	-- list the entity anyway.  Later on, the renamer will change the
+	-- orig name into the import name, so we get a proper link to
+	-- the doc for this entity.
+	where 
+              Just mdl = nameModule t
+              x = nameOccName
+	      subs = map nameOfQName subs_qnames
+	      subs_qnames = filter (`elem` exported_names) all_subs_qnames
+
+	      all_subs_qnames = map (Qual mdl) all_subs
+
+	      all_subs | mdl == this_mod = Map.findWithDefault [] x sub_map
+		       | otherwise       = all_subs_of_qname mod_map t
+
+    fullContentsOf m
+	| m == this_mod = return (fullContentsOfThisModule this_mod decls)
+	| otherwise = 
+	   case Map.lookup m mod_map of
+	     Just hmod
+		| OptHide `elem` hmod_options hmod
+			-> return (hmod_orig_exports hmod)
+		| otherwise -> return [ ExportModule m ]
+	     Nothing -> return [] -- already emitted a warning in exportedNames
+
+    findDecl :: GHC.Name -> Maybe (GHC.HsDecl GHC.Name)
+    findDecl n | not (isExternalName n) = Nothing
+    findDecl n =
+	| m == this_mod = Map.lookup n decl_map
+	| otherwise = 
+	   case Map.lookup m mod_map of
+		Just hmod -> Map.lookup n (hmod_decls hmod)
+		Nothing -> Nothing
+      where
+        m = nameModule n
+
+fullContentsOfThisModule :: GHC.Module -> [GHC.HsDecl GHC.Name] -> [ExportItem]
+fullContentsOfThisModule mdl decls = 
+  map mkExportItem (filter keepDecl decls)
+  where mkExportItem (DocD (DocGroup lev doc)) = ExportGroup lev "" doc
+	mkExportItem decl = ExportDecl x decl [] -- NOTE: will this work? is x qualified correctly?
+	     where Just x = GHC.getDeclMainBinder decl
+
+keepDecl :: GHC.HsDecl -> Bool
+keepDecl (GHC.SigD _)                       = True
+keepDecl (GHC.TyClD _)                      = True
+keepDecl (GHC.DocD _)                       = True
+keepDecl (GHC.ForD (GHC.ForeignImport _ _ _ _)) = True
+keepDecl _                              = False
+
+{-
+--< -----------------------------------------------------------------------------
+-- Build the list of items that will become the documentation, from the
+-- export list.  At this point, the list of ExportItems is in terms of
+-- original names.
+
+mkExportItems
 	:: ModuleMap
 	-> Module			-- this module
 	-> [HsQName]			-- exported names (orig)
@@ -803,6 +968,7 @@ mkExportItems mod_map this_mod exported_names decl_map sub_map decls
 		Just iface -> Map.lookup n (iface_decls iface)
 		Nothing -> Nothing
 
+
 fullContentsOfThisModule :: Module -> [HsDecl] -> [ExportItem]
 fullContentsOfThisModule mdl decls = 
   map mkExportItem (filter keepDecl decls)
@@ -820,11 +986,70 @@ keepDecl HsDocGroup{}	   = True
 keepDecl HsForeignImport{} = True
 keepDecl _ = False
 
+-}
+
 -- Sometimes the declaration we want to export is not the "main" declaration:
 -- it might be an individual record selector or a class method.  In these
 -- cases we have to extract the required declaration (and somehow cobble 
 -- together a type signature for it...)
+-- We put noSrcLoc everywhere in the cobbled together type signatures since
+-- they aren't actually located in the soure code.
+ 
+extractDecl :: GHC.Name -> GHC.Module -> GHC.HsDecl GHC.Name -> GHC.HsDecl GHC.Name
+extractDecl name mdl decl
+  | Just n <- getDeclMainBinder decl, n == name = decl
+  | otherwise  =  
+    case decl of
+      GHC.TyClD d | GHC.isClassDecl d -> 
+        let matching_sigs = [ sig | sig <- GHC.tcdSigs d, GHC.sigName sig == Just name ] 
+        in case matching_sigs of 
+          [s0] -> let (n, tyvar_names) = name_and_tyvars d
+                  in SigD (extractClassDecl n mdl tyvar_names s0)
+          _ -> error "internal: extractDecl" 
+      GHC.TyClD d | GHC.isDataDecl d -> 
+        let (n, tyvar_names) = name_and_tyvars d
+        in SigD (extractRecSel name mdl n tyvar_names (GHC.tcdCons d))
+      _ -> error "internal: extractDecl"
+  where
+    name_and_tyvars d = (GHC.unLoc (GHC.tcdLName d), hsLTyVarLocNames (GHC.tcdTyVars d))
+
+toTypeNoLoc :: Located GHC.Name -> LHsType GHC.Name
+toTypeNoLoc lname = mkNoLoc (GHC.HsTyVar (unLoc lname))
 
+mkNoLoc :: a -> Located a
+mkNoLoc a = Located noSrcLoc a
+
+-- originally expected unqualified 1:st name, now it doesn't
+extractClassDecl :: GHC.Name -> GHC.Module -> [GHC.Located GHC.Name] -> GHC.LSig GHC.Name -> GHC.Sig GHC.Name
+extractClassDecl c mdl tvs0 (GHC.Located p (GHC.TypeSig lname ltype)) = case ltype of
+  GHC.Located _ (GHC.HsForAllTy exp tvs (GHC.Located p'' preds) ty) -> 
+    GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp tvs lctxt ty))
+  _ -> GHC.TypeSig lname (mkNoLoc (GHC.HsForAllTy exp [] lctxt ltype))
+    where
+      lctxt = mkNoLoc ctxt
+      ctxt = [mkNoLoc (GHC.HsClassP c (map toTypeNoLoc tvs0))] ++ preds  
+
+extractClassDecl _ _ _ d = error $ "Main.extractClassDecl: unexpected decl"
+
+extractRecSel :: GHC.Located GHC.Name -> GHC.Module -> GHC.Name -> [GHC.Located GHC.Name] -> [GHC.LConDecl GHC.Name]
+              -> GHC.Sig Ghc.Name
+extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found"
+
+-- originally expected unqualified 3:rd name, now it doesn't
+extractRecSel nm mdl t tvs (Located _ con : rest) =
+  case GHC.con_details con of
+    GHC.RecCon fields | (GHC.HsRecField n ty _ : _) <- matching_fields fields -> 
+      GHC.TypeSig nm (mkNoLoc (GHC.HsFunTy data_ty (GHC.getBangType ty)))
+    _ -> extractRecSel nm mdl t tvs rest
+ where 
+  matching_fields flds = [ f | HsRecField n _ _ <- flds, n == nm ]   
+  data_ty = mkNoLoc (foldl HsAppTy (mkNoLoc (HsTyVar t)) (map toTypeNoLoc tvs))
+
+-- Sometimes the declaration we want to export is not the "main" declaration:
+-- it might be an individual record selector or a class method.  In these
+-- cases we have to extract the required declaration (and somehow cobble 
+-- together a type signature for it...)
+{-
 extractDecl :: HsName -> Module -> HsDecl -> HsDecl
 extractDecl name mdl decl
   | Just n <- declMainBinder decl, n == name  =  decl
@@ -870,7 +1095,7 @@ extractRecSel nm mdl t tvs (HsRecDecl loc _ _tvs _ fields _mb_doc : rest)
 			        nm `elem` ns ]
 
 	data_ty = foldl HsTyApp (HsTyCon (Qual mdl t)) (map HsTyVar tvs)
-
+-}
 -- -----------------------------------------------------------------------------
 -- Pruning
 
@@ -1170,7 +1395,7 @@ findNamedDoc name decls = search decls
 	where search [] = do
 		tell ["Cannot find documentation for: $" ++ name]
 		return Nothing
-	      search (HsDocCommentNamed _ name' doc : rest) 
+	      search ((DocD (DocCommentNamed name' doc)):rest) 
 			| name == name' = return (Just doc)
 		   	| otherwise = search rest
 	      search (_other_decl : rest) = search rest