aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Binary.hs549
-rw-r--r--src/FastMutInt.hs58
-rw-r--r--src/HaddockUtil.hs35
-rw-r--r--src/Main.hs91
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)
generated by cgit v1.2.3 (git 2.39.1) at 2025-11-04 07:43:04 +0000