diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Binary2.hs | 687 | ||||
| -rw-r--r-- | src/HaddockHtml.hs | 7 | ||||
| -rw-r--r-- | src/Interface.hs | 345 | ||||
| -rw-r--r-- | src/Main.hs | 8 |
4 files changed, 3 insertions, 1044 deletions
diff --git a/src/Binary2.hs b/src/Binary2.hs deleted file mode 100644 index 2d8b361e..00000000 --- a/src/Binary2.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 Binary2 - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - - openBinIO, - openBinIO_, - openBinMem, --- closeBin, - --- getUserData, - - seekBin, - tellBin, - castBin, - - writeBinMem, - readBinMem, - - isEOFBin, - - -- for writing instances: - putByte, - getByte, - - putString, - getString, - - -- lazy Bin I/O - lazyGet, - lazyPut, - - -- GHC only: - ByteArray(..), - getByteArray, - putByteArray, - --- getBinFileWithDict, -- :: Binary a => FilePath -> IO a --- putBinFileWithDict, -- :: Binary a => FilePath -> Module -> a -> IO () - - -- re-export for the benefit of other modules. - openBinaryFile, - - FormatVersion, - nullFormatVersion, - mkFormatVersion, - ) where - -#include "MachDeps.h" - -import FastMutInt - -import Char -import Monad - -#if __GLASGOW_HASKELL__ < 503 -import IOExts -import Bits -import Int -import Word -import Char -import Monad -import Exception -import GlaExts hiding (ByteArray, newByteArray, freezeByteArray) -import Array -import IO -import PrelIOBase ( IOError(..), IOErrorType(..) -#if __GLASGOW_HASKELL__ > 411 - , IOException(..) -#endif - ) -import PrelReal ( Ratio(..) ) -import PrelIOBase ( IO(..) ) -#else -import Data.Array.IO -import Data.Array -import Data.Bits -import Data.Int -import Data.Word -import Data.IORef -import Data.Char ( ord, chr ) -import Data.Array.Base ( unsafeRead, unsafeWrite ) -import Control.Monad ( when ) -import Control.Exception ( throwDyn ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Exts -import GHC.IOBase ( IO(..) ) -import GHC.Word ( Word8(..) ) -#if __GLASGOW_HASKELL__ < 601 --- openFileEx is available from the lang package, but we want to --- be independent of hslibs libraries. -import GHC.Handle ( openFileEx, IOModeEx(..) ) -#endif -#endif - -import IO - -#if __GLASGOW_HASKELL__ < 601 -openBinaryFile f mode = openFileEx f (BinaryMode mode) -#endif - -#if __GLASGOW_HASKELL__ < 503 -type BinArray = MutableByteArray RealWorld Int -newArray_ bounds = stToIO (newCharArray bounds) -unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e) -unsafeRead arr ix = stToIO (readWord8Array arr ix) -#if __GLASGOW_HASKELL__ < 411 -newByteArray# = newCharArray# -#endif -hPutArray h arr sz = hPutBufBAFull h arr sz -hGetArray h sz = hGetBufBAFull h sz - -mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception -mkIOError t location maybe_hdl maybe_filename - = IOException (IOError maybe_hdl t location "" -#if __GLASGOW_HASKELL__ > 411 - maybe_filename -#endif - ) - -eofErrorType = EOF - -#ifndef SIZEOF_HSINT -#define SIZEOF_HSINT INT_SIZE_IN_BYTES -#endif - -#ifndef SIZEOF_HSWORD -#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES -#endif - -#else -type BinArray = IOUArray Int Word8 -#endif - -data BinHandle - = BinMem { -- binary data stored in an unboxed array - state :: Int, -- sigh, need parameterized modules :-) - off_r :: !FastMutInt, -- the current offset - sz_r :: !FastMutInt, -- size of the array (cached) - arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. - - | BinIO { -- binary data stored in a file - state :: Int, - off_r :: !FastMutInt, -- the current offset (cached) - hdl :: !IO.Handle -- the file handle (must be seekable) - } - -- cache the file ptr in BinIO; using hTell is too expensive - -- to call repeatedly. If anyone else is modifying this Handle - -- at the same time, we'll be screwed. - -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) - -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i - -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinIO_ :: IO.Handle -> IO BinHandle -openBinIO_ h = openBinIO h - -openBinIO :: IO.Handle -> IO BinHandle -openBinIO h = do - r <- newFastMutInt - writeFastMutInt r 0 - return (BinIO undefined r h) - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- newArray_ (0,size-1) - arr_r0 <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r0 <- newFastMutInt - writeFastMutInt sz_r0 size - return (BinMem undefined ix_r sz_r0 arr_r0) - ---noBinHandleUserData :: a ---noBinHandleUserData = error "Binary.BinHandle: no user data" - ---getUserData :: BinHandle -> BinHandleState ---getUserData bh = state bh - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin (BinIO _ ix_r h) (BinPtr p) = do - writeFastMutInt ix_r p - hSeek h AbsoluteSeek (fromIntegral p) -seekBin h@(BinMem _ ix_r sz_r0 _) (BinPtr p) = do - sz <- readFastMutInt sz_r0 - if (p >= sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - -isEOFBin :: BinHandle -> IO Bool -isEOFBin (BinMem _ ix_r sz_r0 _) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - return (ix >= sz) -isEOFBin (BinIO _ _ h) = hIsEOF h - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinIO _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle" -writeBinMem (BinMem _ ix_r _ arr_r0) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r0 - ix <- readFastMutInt ix_r - hPutArray h arr ix - hClose h - -readBinMem :: FilePath -> IO BinHandle -readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - arr <- newArray_ (0,filesize-1) - count <- hGetArray h arr filesize - when (count /= filesize) - (error ("Binary.readBinMem: only read " ++ show count ++ " bytes")) - hClose h - arr_r0 <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r0 <- newFastMutInt - writeFastMutInt sz_r0 filesize - return (BinMem undefined {-initReadState-} ix_r sz_r0 arr_r0) - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ _ sz_r0 arr_r0) off = do - sz <- readFastMutInt sz_r0 - let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) - arr <- readIORef arr_r0 - arr' <- newArray_ (0,sz'-1) - sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i - | i <- [ 0 .. sz-1 ] ] - writeFastMutInt sz_r0 sz' - writeIORef arr_r0 arr' - hPutStrLn stderr ("expanding to size: " ++ show sz') - return () -expandBin (BinIO _ _ _) _ = return () - -- no need to expand a file, we'll assume they expand by themselves. - --- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h@(BinMem _ ix_r sz_r0 arr_r0) w = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - -- double the size of the array if it overflows - if (ix >= sz) - then do expandBin h ix - putWord8 h w - else do arr <- readIORef arr_r0 - unsafeWrite arr ix w - writeFastMutInt ix_r (ix+1) - return () -putWord8 (BinIO _ ix_r h) w = do - ix <- readFastMutInt ix_r - hPutChar h (chr (fromIntegral w)) -- XXX not really correct - writeFastMutInt ix_r (ix+1) - return () - -getWord8 :: BinHandle -> IO Word8 -getWord8 (BinMem _ ix_r sz_r0 arr_r0) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - when (ix >= sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) - arr <- readIORef arr_r0 - w <- unsafeRead arr ix - writeFastMutInt ix_r (ix+1) - return w -getWord8 (BinIO _ ix_r h) = do - ix <- readFastMutInt ix_r - c <- hGetChar h - writeFastMutInt ix_r (ix+1) - return $! (fromIntegral (ord c)) -- XXX not really correct - --- | Get the next byte, but don't change the pointer. -peekWord8 :: BinHandle -> IO Word8 -peekWord8 (BinMem _ ix_r sz_r0 arr_r0) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r0 - when (ix >= sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) - arr <- readIORef arr_r0 - w <- unsafeRead arr ix - return w -peekWord8 (BinIO _ ix_r h) = do - c <- hLookAhead h - return $! (fromIntegral (ord c)) -- XXX not really correct - -putByte :: BinHandle -> Word8 -> IO () -putByte bh w = put_ bh w - -getByte :: BinHandle -> IO Word8 -getByte = getWord8 - --- ----------------------------------------------------------------------------- --- Primitve Word writes - -instance Binary Word8 where - put_ = putWord8 - get = getWord8 - -instance Binary Word16 where - put_ h w = do -- XXX too slow.. inline putWord8? - putByte h (fromIntegral (w `shiftR` 8)) - putByte h (fromIntegral (w .&. 0xff)) - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2) - - -instance Binary Word32 where - put_ h w = do - putByte h (fromIntegral (w `shiftR` 24)) - putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) - putByte h (fromIntegral (w .&. 0xff)) - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - w3 <- getWord8 h - w4 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 24) .|. - (fromIntegral w2 `shiftL` 16) .|. - (fromIntegral w3 `shiftL` 8) .|. - (fromIntegral w4)) - - -instance Binary Word64 where - put_ h w = do - putByte h (fromIntegral (w `shiftR` 56)) - putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff)) - putByte h (fromIntegral ((w `shiftR` 8) .&. 0xff)) - putByte h (fromIntegral (w .&. 0xff)) - get h = do - w1 <- getWord8 h - w2 <- getWord8 h - w3 <- getWord8 h - w4 <- getWord8 h - w5 <- getWord8 h - w6 <- getWord8 h - w7 <- getWord8 h - w8 <- getWord8 h - return $! ((fromIntegral w1 `shiftL` 56) .|. - (fromIntegral w2 `shiftL` 48) .|. - (fromIntegral w3 `shiftL` 40) .|. - (fromIntegral w4 `shiftL` 32) .|. - (fromIntegral w5 `shiftL` 24) .|. - (fromIntegral w6 `shiftL` 16) .|. - (fromIntegral w7 `shiftL` 8) .|. - (fromIntegral w8)) - --- ----------------------------------------------------------------------------- --- Primitve Int writes - -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) - -instance Binary Int16 where - put_ h w = put_ h (fromIntegral w :: Word16) - get h = do w <- get h; return $! (fromIntegral (w::Word16)) - -instance Binary Int32 where - put_ h w = put_ h (fromIntegral w :: Word32) - get h = do w <- get h; return $! (fromIntegral (w::Word32)) - -instance Binary Int64 where - put_ h w = put_ h (fromIntegral w :: Word64) - get h = do w <- get h; return $! (fromIntegral (w::Word64)) - --- ----------------------------------------------------------------------------- --- Instances for standard types - -instance Binary () where - put_ _ () = return () - get _ = return () --- getF bh p = case getBitsF bh 0 p of (_,b) -> ((),b) - -instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) --- getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b) - -instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) --- getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b) - -instance Binary Int where -#if SIZEOF_HSINT == 4 - put_ bh i = put_ bh (fromIntegral i :: Int32) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int32)) -#elif SIZEOF_HSINT == 8 - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) -#else -#error "unsupported sizeof(HsInt)" -#endif --- getF bh = getBitsF bh 32 - -{- -instance Binary a => Binary [a] where - put_ bh [] = putByte bh 0 - put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs - get bh = do h <- getWord8 bh - case h of - 0 -> return [] - _ -> do x <- get bh - xs <- get bh - return (x:xs) --} -instance Binary a => Binary [a] where - put_ bh l = - do put_ bh (length l) - mapM (put_ bh) l - return () - get bh = - do len <- get bh - mapM (\_ -> get bh) [1..(len::Int)] - -instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) - -instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) - -instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (a,b,c,d) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where - put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where - put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) - -instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f,Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) - -instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) - -instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) - -instance Binary Integer where - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - p <- putByte bh 1; - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - - -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s0 -> - case newByteArray# sz s0 of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr0 = IO $ \s0 -> - case unsafeFreezeByteArray# arr0 s0 of { (# s, arr #) -> - (# s, BA arr #) } - -writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () - -writeByteArray arr i w8 = IO $ \s0 -> - case fromIntegral w8 of { W# w# -> - case writeCharArray# arr i (chr# (word2Int# w#)) s0 of { s -> - (# s , () #) }} - -indexByteArray :: ByteArray# -> Int# -> Word8 -indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#))) - -instance (Integral a, Binary a) => Binary (Ratio a) where - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - -instance Binary (Bin a) where - put_ bh (BinPtr i) = put_ bh i - get bh = do i <- get bh; return (BinPtr i) - --- ----------------------------------------------------------------------------- --- Strings - --- should put a string in UTF-8 (just throws away top 24 bits at the moment) -putString :: BinHandle -> String -> IO () -putString bh str = put_ bh word8s - where - word8s :: [Word8] - word8s = map (fromIntegral.ord) str - -getString :: BinHandle -> IO String -getString bh = do - word8s <- get bh - return (map (chr.fromIntegral) (word8s :: [Word8])) - --- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO (getAt bh p_a) - seekBin bh p -- skip over the object for now - return a - --- ----------------------------------------------------------------------------- --- FormatVersion's. --- The FormatVersion is always non-negative. Furthermore, if the --- FormatVersion is 0, nothing is output. --- --- FormatVersion should only be encoded before something we KNOW to have --- an encoding which never begins with a negative byte, such as a non-negative --- integer or a list. --- --- The advantage of this is that we can read a FormatVersion (which will --- be the nullFormatVersion) even when we didn't write one in the first --- place, such as from earlier versions of this program, just so long --- as we did at any rate write a list. - -newtype FormatVersion = FormatVersion Int deriving (Eq,Ord) - -nullFormatVersion :: FormatVersion -nullFormatVersion = mkFormatVersion 0 - -mkFormatVersion :: Int -> FormatVersion -mkFormatVersion i = FormatVersion i - -instance Binary FormatVersion where - put_ bh (FormatVersion i) = - case compare i 0 of - EQ -> return () - GT -> put_ bh (-i) - LT -> error ( - "Binary.hs: negative FormatVersion " ++ show i - ++ " is not allowed") - get bh = - do - w8 <- peekWord8 bh - if testBit w8 7 - then - do - i <- get bh - return (FormatVersion (-i)) - else - return nullFormatVersion diff --git a/src/HaddockHtml.hs b/src/HaddockHtml.hs index fae29820..6580d27e 100644 --- a/src/HaddockHtml.hs +++ b/src/HaddockHtml.hs @@ -12,7 +12,6 @@ module HaddockHtml ( import Prelude hiding (div) -import Binary2 ( openBinaryFile ) import HaddockDevHelp import HaddockHH import HaddockHH2 @@ -29,7 +28,7 @@ import Data.Char ( isUpper, toUpper ) import Data.List ( sortBy ) import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe ) import Foreign.Marshal.Alloc ( allocaBytes ) -import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf ) +import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) import Debug.Trace ( trace ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) @@ -114,8 +113,8 @@ ppHtmlHelpFiles doctitle maybe_package hmods odir maybe_html_help_format pkg_pat copyFile :: FilePath -> FilePath -> IO () copyFile fromFPath toFPath = - (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> - bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo -> + (bracket (openFile fromFPath ReadMode) hClose $ \hFrom -> + bracket (openFile toFPath WriteMode) hClose $ \hTo -> allocaBytes bufferSize $ \buffer -> copyContents hFrom hTo buffer) where diff --git a/src/Interface.hs b/src/Interface.hs deleted file mode 100644 index 0578fe83..00000000 --- a/src/Interface.hs +++ /dev/null @@ -1,345 +0,0 @@ -module Interface ( - Interface, - dumpInterface, - readInterface -) where - -import HaddockUtil ( noDieMsg, moduleString ) -import Binary2 ( BinHandle, Binary(..), FormatVersion, mkFormatVersion, - openBinMem, writeBinMem, readBinMem, putByte, getByte, - getString, putString ) - -import Name ( Name, nameOccName, nameModule, mkExternalName ) -import OccName ( OccName, isVarOcc, isDataOcc, isTvOcc, isTcOcc, varName, - dataName, tvName, tcClsName, occNameString, mkOccName ) -import Unique ( mkUnique ) -import Module ( Module, mkModule, mkModuleName, modulePackageId ) -import PackageConfig ( packageIdString, stringToPackageId ) -import SrcLoc ( noSrcLoc ) - -import qualified Data.Map as Map -import Data.Map (Map) - ------------------------------------------------------------------------------- --- Reading the current interface format ------------------------------------------------------------------------------- - -thisFormatVersion :: FormatVersion -thisFormatVersion = mkFormatVersion 3 - -dumpInterface :: Map Name Name -> [Module] -> FilePath -> IO () -dumpInterface globalDocEnv modules fileName = do - bh <- openBinMem 100000 - put_ bh thisFormatVersion - mapM (put_ bh) modules - putDocEnv bh globalDocEnv - writeBinMem bh fileName - -putDocEnv :: BinHandle -> Map Name Name -> IO () -putDocEnv bh env = put_ bh list - where - list = [ (nameModule o, nameOccName o, nameModule e) | - (o, e) <- Map.toList env ] - -getDocEnv :: BinHandle -> IO (Map Name Name) -getDocEnv bh = do - list <- get bh - return (Map.fromList [(mkName mdl1 occ, mkName mdl2 occ) | - (mdl1,occ,mdl2) <- list]) - -mkName mdl occ = mkExternalName (mkUnique 'X' 0) mdl occ Nothing noSrcLoc - -type Interface = ([Module], Map Name Name) - -readInterface :: FilePath -> IO Interface -readInterface fileName = do - bh <- readBinMem fileName - formatVersion <- get bh - case formatVersion of - v | v == thisFormatVersion -> do - modules::[Module] <- get bh - env <- getDocEnv bh - return (modules, env) --- v | v == mkFormatVersion 2 -> do --- (stuff :: [StoredInterface2]) <- get bh --- return ([], Map.empty) --- doc_env <- getDocEnv bh --- return (map toInterface2 stuff, doc_env) - otherwise -> do - noDieMsg ( - "Warning: The interface file " ++ show fileName - ++ " could not be read.\n" - ++ "Interface files from earlier version of Haddock are not " - ++ "supported yet.\n") - return ([],Map.empty) - -encodeNS n - | isVarOcc n = 0 - | isDataOcc n = 1 - | isTvOcc n = 2 - | isTcOcc n = 3 - -decodeNS n = case n of - 0 -> varName - 1 -> dataName - 2 -> tvName - _ -> tcClsName - -instance Binary OccName where - put_ bh n = do - put_ bh (occNameString n) - putByte bh (encodeNS n) - get bh = do - string <- get bh - ns <- getByte bh - return (mkOccName (decodeNS ns) string) - -instance Binary Module where - put_ bh m = do - put_ bh (moduleString m) - put_ bh ((packageIdString . modulePackageId) m) - get bh = do - m <- get bh - p <- get bh - return (mkModule (stringToPackageId p) (mkModuleName m)) - ------------------------------------------------------------------------------- --- Reading old interface formats ------------------------------------------------------------------------------- - -type StoredInterface2 = - (Module2, Maybe Doc2, Maybe String, Bool, - [(HsName, Module2)], [(HsName, [HsName])]) - -newtype Module2 = Module2 String - deriving (Eq,Ord) - -data HsQName - = Qual Module HsName - | UnQual HsName - deriving (Eq,Ord) - -data HsName - = HsTyClsName HsIdentifier - | HsVarName HsIdentifier - deriving (Eq,Ord) - -data HsIdentifier - = HsIdent String - | HsSymbol String - | HsSpecial String - deriving (Eq,Ord) - -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 Doc2 = GenDoc [HsQName] - ------------------------------------------------------------------------------- --- Binary instances for stuff ------------------------------------------------------------------------------- - -instance Binary Module2 where - put_ bh (Module2 m) = putString bh m - get bh = do m <- getString bh; return $! (Module2 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) - -instance Binary id => Binary (GenDoc id) where - put_ bh DocEmpty = putByte bh 0 - put_ bh (DocAppend gd1 gd2) = do putByte bh 1;put_ bh gd1;put_ bh gd2 - put_ bh (DocString s) = do putByte bh 2;putString bh s - put_ bh (DocParagraph gd) = do putByte bh 3;put_ bh gd - put_ bh (DocIdentifier id) = do putByte bh 4;put_ bh id - put_ bh (DocModule s) = do putByte bh 5;putString bh s - put_ bh (DocEmphasis gd) = do putByte bh 6;put_ bh gd - put_ bh (DocMonospaced gd) = do putByte bh 7;put_ bh gd - put_ bh (DocUnorderedList gd) = do putByte bh 8;put_ bh gd - put_ bh (DocOrderedList gd) = do putByte bh 9;put_ bh gd - put_ bh (DocDefList gd) = do putByte bh 10;put_ bh gd - put_ bh (DocCodeBlock gd) = do putByte bh 11;put_ bh gd - put_ bh (DocURL s) = do putByte bh 12;putString bh s - put_ bh (DocAName s) = do putByte bh 13;putString bh s - get bh = do b <- getByte bh - case b of - 0 -> return DocEmpty - 1 -> do gd1 <- get bh;gd2 <- get bh;return (DocAppend gd1 gd2) - 2 -> do s <- getString bh;return (DocString s) - 3 -> do gd <- get bh;return (DocParagraph gd) - 4 -> do id <- get bh;return (DocIdentifier id) - 5 -> do s <- getString bh;return (DocModule s) - 6 -> do gd <- get bh;return (DocEmphasis gd) - 7 -> do gd <- get bh;return (DocMonospaced gd) - 8 -> do gd <- get bh;return (DocUnorderedList gd) - 9 -> do gd <- get bh;return (DocOrderedList gd) - 10 -> do gd <- get bh;return (DocDefList gd) - 11 -> do gd <- get bh;return (DocCodeBlock gd) - 12 -> do s <- getString bh;return (DocURL s) - 13 -> do s <- getString bh;return (DocAName s) - _ -> error ("Mysterious byte in document in interface" - ++ show b) - -{- --- | How we store interfaces. Not everything is stored. -type StoredInterface1 = - (Module,Maybe Doc,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)], - [(HsName,[HsName])]) - --- | How we used to store interfaces. -type NullVersionStoredInterface = - (Module,Maybe String,Bool,[(HsName,HsQName)],[(HsName,HsQName)], - [(HsName,[HsName])]) - -dumpInterfaces :: [Interface] -> Map HsQName HsQName -> FilePath -> IO () -dumpInterfaces interfaces global_doc_env fileName = - do - let - preparedInterfaces :: [StoredInterface2] - preparedInterfaces = map from_interface interfaces - - bh <- openBinMem 100000 - put_ bh thisFormatVersion - put_ bh preparedInterfaces - putDocEnv bh global_doc_env - writeBinMem bh fileName - - -readIface :: FilePath -> IO ([Interface], Map HsQName HsQName) -readIface fileName = do - bh <- readBinMem fileName - formatVersion <- get bh - case formatVersion of - v | v == thisFormatVersion -> do - (stuff :: [StoredInterface2]) <- get bh - doc_env <- getDocEnv bh - return (map to_interface2 stuff, doc_env) - v | v == mkFormatVersion 1 -> do - (stuff :: [StoredInterface1]) <- get bh - return (map to_interface1 stuff, Map.empty) - v | v == nullFormatVersion -> do - (stuff :: [NullVersionStoredInterface]) <- get bh - return (map nullVersion_to_interface stuff, Map.empty) - otherwise -> do - noDieMsg ( - "Warning: The interface file " ++ show fileName - ++ " could not be read.\n" - ++ "Maybe it's from a later version of Haddock?\n") - return ([], Map.empty) - -from_interface :: Interface -> StoredInterface2 -from_interface iface = - ( iface_module iface, - toDescription iface,iface_package iface, - OptHide `elem` iface_options iface, - [(n,mdl) | (n,Qual mdl n') <- Map.toAscList (iface_env iface), - if n /= n' then error "help!" else True], - Map.toAscList (iface_sub iface) - ) - -getDocEnv :: BinHandle -> IO (Map HsQName HsQName) -getDocEnv bh = do - doc_env_list <- get bh - return (Map.fromList [(Qual mdl1 nm,Qual mdl2 nm) | - (mdl1,nm,mdl2) <- doc_env_list]) - -to_interface1 :: StoredInterface1 -> Interface -to_interface1 (mdl,descriptionOpt,package, hide, env, _, sub) = - Interface { - iface_module = mdl, - iface_filename = "", - iface_orig_filename= "", - iface_package = package, - iface_env = Map.fromList env, - iface_sub = Map.fromList sub, - iface_reexported = [], - iface_exports = [], - iface_orig_exports = [], - iface_insts = [], - iface_decls = Map.empty, - iface_info = toModuleInfo descriptionOpt, - iface_doc = Nothing, - iface_options = if hide then [OptHide] else [] - } - -to_interface2 :: StoredInterface2 -> Interface -to_interface2 (mdl,descriptionOpt,package, hide, env, sub) = - Interface { - iface_module = mdl, - iface_filename = "", - iface_orig_filename= "", - iface_package = package, - iface_env = - Map.fromList [(n,Qual mdl n) | (n,mdl) <- env], - iface_sub = Map.fromList sub, - iface_reexported = [], - iface_exports = [], - iface_orig_exports = [], - iface_insts = [], - iface_decls = Map.empty, - iface_info = toModuleInfo descriptionOpt, - iface_doc = Nothing, - iface_options = if hide then [OptHide] else [] - } - -nullVersion_to_interface :: NullVersionStoredInterface -> Interface -nullVersion_to_interface (mdl, package, hide, env, reexported, sub) = - Interface { - iface_module = mdl, - iface_filename = "", - iface_orig_filename= "", - iface_package = package, - iface_env = Map.fromList env, - iface_sub = Map.fromList sub, - iface_reexported = [], - iface_exports = [], - iface_orig_exports = [], - iface_insts = [], - iface_decls = Map.empty, - iface_info = emptyModuleInfo, - iface_doc = Nothing, - iface_options = if hide then [OptHide] else [] - } - -toModuleInfo :: Maybe Doc -> ModuleInfo -toModuleInfo descriptionOpt = - emptyModuleInfo {description = descriptionOpt} - --} diff --git a/src/Main.hs b/src/Main.hs index 1b8116fc..cd406294 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,6 @@ import HaddockTypes import HaddockUtil import HaddockVersion import Paths_haddock ( getDataDir ) -import Interface ( Interface, dumpInterface, readInterface ) import Prelude hiding ( catch ) import Control.Exception ( bracket, throwIO, catch, Exception(..) ) @@ -415,13 +414,6 @@ run flags modules extEnv = do maybe_source_urls maybe_wiki_urls maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file - - return () - - -- dump an interface if requested - case dumpIface of - Nothing -> return () - Just fn -> dumpInterface env (map hmod_mod visibleMods) fn where pprList [] = [] pprList [x] = show x |