diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Binary.hs | 549 | ||||
| -rw-r--r-- | src/FastMutInt.hs | 58 | ||||
| -rw-r--r-- | src/HaddockUtil.hs | 35 | ||||
| -rw-r--r-- | src/Main.hs | 91 |
4 files changed, 724 insertions, 9 deletions
diff --git a/src/Binary.hs b/src/Binary.hs new file mode 100644 index 00000000..9d1d11af --- /dev/null +++ b/src/Binary.hs @@ -0,0 +1,549 @@ +{-# OPTIONS -cpp #-} +-- +-- (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 () + + ) where + +#include "MachDeps.h" + +import FastMutInt + +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(..) ) +import PrelReal -- ( Ratio(..) ) +import PrelIOBase -- ( IO(..) ) +import MArray (IOUArray) + +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) + +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 "" + maybe_filename + ) + +eofErrorType = EOF + +#ifndef SIZEOF_HSINT +#define SIZEOF_HSINT INT_SIZE_IN_BYTES +#endif + +#ifndef SIZEOF_HSWORD +#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES +#endif + +--type BinArray = IOUArray Int Word8 + +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_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem undefined ix_r sz_r arr_r) + +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_r a) (BinPtr p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem _ ix_r sz_r a) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) +isEOFBin (BinIO _ ix_r h) = hIsEOF h + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" +writeBinMem (BinMem _ ix_r sz_r arr_r) fn = do + h <- openFileEx fn (BinaryMode WriteMode) + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + hPutArray h arr ix + hClose h + +readBinMem :: FilePath -> IO BinHandle +readBinMem filename = do + h <- openFileEx filename (BinaryMode ReadMode) + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- newArray_ (0,filesize-1) + count <- hGetArray h arr filesize + when (count /= filesize) + (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem undefined {-initReadState-} ix_r sz_r arr_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ ix_r sz_r arr_r) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- newArray_ (0,sz'-1) + sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i + | i <- [ 0 .. sz-1 ] ] + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + 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_r arr_r) w = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + -- double the size of the array if it overflows + if (ix >= sz) + then do expandBin h ix + putWord8 h w + else do arr <- readIORef arr_r + unsafeWrite arr ix w + writeFastMutInt ix_r (ix+1) + return () +putWord8 (BinIO _ ix_r h) w = do + ix <- readFastMutInt ix_r + hPutChar h (chr (fromIntegral w)) -- XXX not really correct + writeFastMutInt ix_r (ix+1) + return () + +getWord8 :: BinHandle -> IO Word8 +getWord8 (BinMem _ ix_r sz_r arr_r) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix >= sz) $ + throw (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) + arr <- readIORef arr_r + w <- unsafeRead arr ix + writeFastMutInt ix_r (ix+1) + return w +getWord8 (BinIO _ ix_r h) = do + ix <- readFastMutInt ix_r + c <- hGetChar h + writeFastMutInt ix_r (ix+1) + return $! (fromIntegral (ord c)) -- XXX not really correct + +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_ bh () = return () + get _ = return () +-- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) +-- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) +-- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) + +instance Binary Int where +#if SIZEOF_HSINT == 4 + put_ bh i = put_ bh (fromIntegral i :: Int32) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int32)) +#elif SIZEOF_HSINT == 8 + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) +#else +#error "unsupported sizeof(HsInt)" +#endif +-- 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 (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 $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () + +writeByteArray arr i w8 = IO $ \s -> + case word8ToWord w8 of { W# w# -> + case writeCharArray# arr i (chr# (word2Int# w#)) s of { s -> + (# s , () #) }} + +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 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 diff --git a/src/FastMutInt.hs b/src/FastMutInt.hs new file mode 100644 index 00000000..6b25e360 --- /dev/null +++ b/src/FastMutInt.hs @@ -0,0 +1,58 @@ +{-# OPTIONS -cpp #-} +-- +-- (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 + + +import GlaExts +import PrelIOBase + +#if __GLASGOW_HASKELL__ < 411 +newByteArray# = newCharArray# +#endif + +#ifdef __GLASGOW_HASKELL__ +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt :: IO FastMutInt +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where I# size = SIZEOF_HSINT + +readFastMutInt :: FastMutInt -> IO Int +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt :: FastMutInt -> Int -> IO () +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +incFastMutInt :: FastMutInt -> IO Int -- Returns original value +incFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# 1#) s of { s -> + (# s, I# i #) } } + +incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value +incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + case writeIntArray# arr 0# (i +# n) s of { s -> + (# s, I# i #) } } +#endif + diff --git a/src/HaddockUtil.hs b/src/HaddockUtil.hs index b0ad3544..27a83770 100644 --- a/src/HaddockUtil.hs +++ b/src/HaddockUtil.hs @@ -26,6 +26,8 @@ import List ( intersect ) import IO ( hPutStr, stderr ) import System import RegexString +import Binary +import IOExts -- ----------------------------------------------------------------------------- -- Some Utilities @@ -220,3 +222,36 @@ mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) mapMaybeM f Nothing = return Nothing mapMaybeM f (Just a) = f a >>= return . Just +----------------------------------------------------------------------------- +-- Binary instances for stuff + +instance Binary Module where + put_ bh (Module m) = putString bh m + get bh = do m <- getString bh; return $! (Module m) + +instance Binary HsQName where + put_ bh (Qual m s) = do putByte bh 0; put_ bh m; put_ bh s + put_ bh (UnQual s) = do putByte bh 1; put_ bh s + get bh = do b <- getByte bh + case b of + 0 -> do m <- get bh; s <- get bh; return (Qual m s) + _ -> do s <- get bh; return (UnQual s) + +instance Binary HsName where + put_ bh (HsTyClsName s) = do putByte bh 0; put_ bh s + put_ bh (HsVarName s) = do putByte bh 1; put_ bh s + get bh = do b <- getByte bh + case b of + 0 -> do s <- get bh; return (HsTyClsName s) + _ -> do s <- get bh; return (HsVarName s) + +instance Binary HsIdentifier where + put_ bh (HsIdent s) = do putByte bh 0; putString bh s + put_ bh (HsSymbol s) = do putByte bh 1; putString bh s + put_ bh (HsSpecial s) = do putByte bh 2; putString bh s + get bh = do b <- getByte bh + case b of + 0 -> do s <- getString bh; return (HsIdent s) + 1 -> do s <- getString bh; return (HsSymbol s) + _ -> do s <- getString bh; return (HsSpecial s) + diff --git a/src/Main.hs b/src/Main.hs index 3d8c86dc..e6c9576f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,6 +14,7 @@ import HaddockHtml import HaddockTypes import HaddockUtil import Digraph +import Binary import HsParser import HsParseMonad @@ -29,7 +30,10 @@ import List ( nub ) import Monad ( when ) import Char ( isSpace ) import IO + +#ifdef __GLASGOW_HASKELL__ import IOExts +#endif import MonadWriter @@ -60,6 +64,9 @@ data Flag | Flag_CSS String | Flag_Lib String | Flag_OutputDir FilePath + | Flag_ReadInterface FilePath + | Flag_DumpInterface FilePath + | Flag_NoImplicitPrelude deriving (Eq) options = @@ -78,10 +85,16 @@ options = "page heading", Option ['v'] ["verbose"] (NoArg Flag_Verbose) "be verbose", + Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") + "read an interface from FILE", + Option [] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") + "dump an interface for these modules in FILE", Option [] ["css"] (ReqArg Flag_CSS "FILE") "The CSS file to use for HTML output", Option [] ["lib"] (ReqArg Flag_Lib "DIR") - "Directory containing Haddock's auxiliary files" + "Directory containing Haddock's auxiliary files", + Option [] ["no-implicit-prelude"] (NoArg Flag_NoImplicitPrelude) + "Do not assume Prelude is imported" ] saved_flags :: IORef [Flag] @@ -108,11 +121,24 @@ run flags files = do [] -> return "." fs -> return (last fs) + let dump_iface = case [str | Flag_DumpInterface str <- flags] of + [] -> Nothing + fs -> Just (last fs) + + ifaces_to_read = [str | Flag_ReadInterface str <- flags] + + no_implicit_prelude = Flag_NoImplicitPrelude `elem` flags + prologue <- getPrologue flags writeIORef saved_flags flags parsed_mods <- sequence (map parse_file files) + read_ifaces_s <- mapM readIface ifaces_to_read + + let read_ifaces = concat read_ifaces_s + external_mods = map fst read_ifaces + sorted_mod_files <- sortModules (zip parsed_mods files) -- emits an error message if there are recursive modules @@ -121,21 +147,59 @@ run flags files = do let loop ifaces [] = return ifaces loop ifaces ((hsmod,file):mods) = do - let ((mod,iface),msgs) = runWriter (mkInterface ifaces file hsmod) + let ((mod,iface),msgs) = runWriter $ + mkInterface no_implicit_prelude ifaces file hsmod new_ifaces = addToFM ifaces mod iface mapM (hPutStrLn stderr) msgs loop new_ifaces mods - module_map <- loop emptyFM sorted_mod_files + module_map <- loop (listToFM read_ifaces) sorted_mod_files let mod_ifaces = fmToList module_map + these_mod_ifaces = [ (mod, iface) + | (mod, iface) <- mod_ifaces, + mod `notElem` external_mods ] + -- when (Flag_DocBook `elem` flags) $ -- putStr (ppDocBook odir mod_ifaces) - let inst_maps = collectInstances mod_ifaces + let inst_maps = collectInstances these_mod_ifaces when (Flag_Html `elem` flags) $ - ppHtml title source_url mod_ifaces odir css_file libdir inst_maps prologue + ppHtml title source_url these_mod_ifaces odir css_file + libdir inst_maps prologue + + -- dump an interface if requested + case dump_iface of + Nothing -> return () + Just fn -> do + bh <- openBinMem 100000 + put_ bh prepared_ifaces + writeBinMem bh fn + where + prepared_ifaces = [ (mod, fmToList (iface_env iface)) + | (mod, iface) <- these_mod_ifaces ] + +readIface :: FilePath -> IO [(Module,Interface)] +readIface filename = do + bh <- readBinMem filename + stuff <- get bh + return (map to_interface stuff) + where + to_interface (mod, env) = + (mod, Interface { + iface_filename = "", + iface_env = listToFM env, + iface_exports = [], + iface_orig_exports = [], + iface_insts = [], + iface_decls = emptyFM, + iface_info = Nothing, + iface_doc = Nothing, + iface_options = [] + } + ) + parse_file file = do bracket @@ -163,13 +227,14 @@ getPrologue flags -- Figuring out the definitions that are exported from a module mkInterface - :: ModuleMap -> FilePath -> HsModule + :: Bool -- no implicit prelude + -> ModuleMap -> FilePath -> HsModule -> ErrMsgM ( Module, -- the module name Interface -- its "interface" ) -mkInterface mod_map filename +mkInterface no_implicit_prelude mod_map filename (HsModule mod exps imps decls maybe_opts maybe_info maybe_doc) = do -- Process the options, if available @@ -191,9 +256,16 @@ mkInterface mod_map filename zip qual_local_names qual_local_names) -- both qualified and unqualifed names are in scope for local things + implicit_imps + | no_implicit_prelude || any is_prel_import imps = imps + | otherwise = HsImportDecl loc prelude_mod False Nothing Nothing : imps + where + loc = SrcLoc 0 0 + is_prel_import (HsImportDecl _ mod _ _ _ ) = mod == prelude_mod + -- build the orig_env, which maps names to *original* names (so we can -- find the original declarations & docs for things). - orig_env = buildOrigEnv mod_map imps `plusFM` local_orig_env + orig_env = buildOrigEnv mod_map implicit_imps `plusFM` local_orig_env -- convert names in source code to original, fully qualified, names (orig_exports, missing_names1) @@ -214,7 +286,8 @@ mkInterface mod_map filename -- build the import env, which maps original names to import names local_import_env = listToFM (zip qual_local_names qual_local_names) import_env = local_import_env `plusFM` - buildImportEnv mod_map mod exported_visible_names imps + buildImportEnv mod_map mod exported_visible_names + implicit_imps let final_decls = concat (map expandDecl orig_decls) |