zlib (empty) → 0.2
raw patch · 7 files changed
+1041/−0 lines, 7 filesdep +basedep +fpsbuild-type:Customsetup-changed
Dependencies added: base, fps
Files
- Codec/Compression/GZip.hs +89/−0
- Codec/Compression/Zlib.hs +41/−0
- Codec/Compression/Zlib/Internal.hs +247/−0
- Codec/Compression/Zlib/Raw.hs +41/−0
- Codec/Compression/Zlib/Stream.hsc +604/−0
- Setup.hs +2/−0
- zlib.cabal +17/−0
+ Codec/Compression/GZip.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (c) 2006 Duncan Coutts+-- License : BSD-style+--+-- Maintainer : duncan.coutts@worc.ox.ac.uk+-- Stability : experimental+-- Portability : portable (H98 + FFI)+--+-- Compression and decompression of data streams in the gzip format.+--+-- The format is described in detail in RFC #1952:+-- <http://www.ietf.org/rfc/rfc1952.txt>+--+-- See also the zlib home page: <http://zlib.net/>+--+-----------------------------------------------------------------------------+module Codec.Compression.GZip (++ -- | This module provides pure functions for compressing and decompressing+ -- streams of data represented by lazy 'ByteString's. This makes it easy to+ -- use either in memory or with disk or network IO.+ --+ -- For example a simple gzip compression program is just:+ --+ -- > import qualified Data.ByteString.Lazy as ByteString+ -- > import qualified Codec.Compression.GZip as GZip+ -- >+ -- > main = ByteString.interact GZip.compress+ --+ -- Or you could lazily read in and decompress a @.gz@ file using:+ --+ -- > content <- fmap GZip.decompress (readFile file)+ --++ -- * Compression+ compress,+ compressWith,+ CompressionLevel(..),+ + -- * Decompression+ decompress+ + ) where++import Data.ByteString.Lazy (ByteString)++import Codec.Compression.Zlib.Internal as Internal+++-- | Decompress a stream of data in the gzip format.+--+-- There are a number of errors that can occur. In each case an exception will+-- be thrown. The possible error conditions are:+--+-- * if the stream does not start with a valid gzip header+--+-- * if the compressed stream is corrupted+--+-- * if the compressed stream ends permaturely+--+-- Note that the decompression is performed /lazily/. Errors in the data stream+-- may not be detected until the end of the stream is demanded (since it is+-- only at the end that the final checksum can be checked). If this is+-- important to you, you must make sure to consume the whole decompressed+-- stream before doing any IO action that depends on it.+--+decompress :: ByteString -> ByteString+decompress = Internal.decompressDefault GZip+++-- | Compress a stream of data into the gzip format.+--+-- This uses the default compression level which favours a higher compression+-- ratio over compression speed. Use 'compressWith' to adjust the compression+-- level.+--+compress :: ByteString -> ByteString+compress = Internal.compressDefault GZip DefaultCompression+++-- | Like 'compress' but with an extra parameter to specify the compression+-- level.+--+-- There are a number of additional compression parameters which are rarely+-- necessary to change but if you need to you can do so using 'compressFull'.+--+compressWith ::CompressionLevel -> ByteString -> ByteString+compressWith = Internal.compressDefault GZip
+ Codec/Compression/Zlib.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (c) 2006 Duncan Coutts+-- License : BSD-style+--+-- Maintainer : duncan.coutts@worc.ox.ac.uk+-- Stability : experimental+-- Portability : portable (H98 + FFI)+--+-- Compression and decompression of data streams in the zlib format.+--+-- The format is described in detail in RFC #1950:+-- <http://www.ietf.org/rfc/rfc1950.txt>+--+-- See also the zlib home page: <http://zlib.net/>+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib (+ + -- * Compression+ compress,+ compressWith,+ CompressionLevel(..),+ + -- * Decompression+ decompress+ + ) where++import Data.ByteString.Lazy (ByteString)++import Codec.Compression.Zlib.Internal as Internal++decompress :: ByteString -> ByteString+decompress = Internal.decompressDefault Zlib++compress :: ByteString -> ByteString+compress = Internal.compressDefault Zlib DefaultCompression++compressWith ::CompressionLevel -> ByteString -> ByteString+compressWith = Internal.compressDefault Zlib
+ Codec/Compression/Zlib/Internal.hs view
@@ -0,0 +1,247 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (c) 2006 Duncan Coutts+-- License : BSD-style+--+-- Maintainer : duncan.coutts@worc.ox.ac.uk+-- Stability : experimental+-- Portability : portable (H98 + FFI)+--+-- Pure stream based interface to lower level zlib wrapper+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib.Internal (++ -- * Compression and decompression+ compressDefault,+ decompressDefault,+ Stream.Format(..),+ Stream.CompressionLevel(..),++ -- * The same but with the full set of parameters+ compressFull,+ decompressFull,+ Stream.Method(..),+ Stream.WindowBits(..),+ Stream.MemoryLevel(..),+ Stream.CompressionStrategy(..),++ ) where++import Prelude hiding (length)+import Control.Monad (liftM, when)+import Control.Exception (assert)+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Base as Base+import Data.ByteString.Base (LazyByteString(LPS))++import qualified Codec.Compression.Zlib.Stream as Stream+import Codec.Compression.Zlib.Stream (Stream)++compressDefault+ :: Stream.Format+ -> Stream.CompressionLevel+ -> Lazy.ByteString+ -> Lazy.ByteString+compressDefault format compressionLevel =+ compressFull format+ compressionLevel+ Stream.Deflated+ Stream.DefaultWindowBits+ Stream.DefaultMemoryLevel+ Stream.DefaultStrategy++decompressDefault+ :: Stream.Format+ -> Lazy.ByteString+ -> Lazy.ByteString+decompressDefault format =+ decompressFull format+ Stream.DefaultWindowBits++{-# NOINLINE compressFull #-}+compressFull+ :: Stream.Format+ -> Stream.CompressionLevel+ -> Stream.Method+ -> Stream.WindowBits+ -> Stream.MemoryLevel+ -> Stream.CompressionStrategy+ -> Lazy.ByteString+ -> Lazy.ByteString+compressFull format compLevel method bits memLevel strategy (LPS chunks) =+ Stream.run $ do+ Stream.deflateInit format compLevel method bits memLevel strategy+ case chunks of+ [] -> liftM LPS (fillBuffers [])+ (Base.PS inFPtr offset length : chunks') -> do+ Stream.pushInputBuffer inFPtr offset length+ liftM LPS (fillBuffers chunks')++ where+ outChunkSize :: Int+ outChunkSize = 16 * 1024 - 16++ -- we flick between two states:+ -- * where one or other buffer is empty+ -- - in which case we refill one or both+ -- * where both buffers are non-empty+ -- - in which case we compress until a buffer is empty++ fillBuffers ::+ [Strict.ByteString]+ -> Stream [Strict.ByteString]+ fillBuffers inChunks = do+ Stream.consistencyCheck++ -- in this state there are two possabilities:+ -- * no outbut buffer space is available+ -- - in which case we must make more available+ -- * no input buffer is available+ -- - in which case we must supply more+ inputBufferEmpty <- Stream.inputBufferEmpty+ outputBufferFull <- Stream.outputBufferFull++ assert (inputBufferEmpty || outputBufferFull) $ return ()++ when outputBufferFull $ do+ outFPtr <- Stream.unsafeLiftIO (Base.mallocByteString outChunkSize)+ Stream.pushOutputBuffer outFPtr 0 outChunkSize++ if inputBufferEmpty+ then case inChunks of+ [] -> drainBuffers []+ (Base.PS inFPtr offset length : inChunks') -> do+ Stream.pushInputBuffer inFPtr offset length+ drainBuffers inChunks'+ else drainBuffers inChunks+++ drainBuffers ::+ [Strict.ByteString]+ -> Stream [Strict.ByteString]+ drainBuffers inChunks = do++ inputBufferEmpty' <- Stream.inputBufferEmpty+ outputBufferFull' <- Stream.outputBufferFull+ assert(not outputBufferFull'+ && (null inChunks || not inputBufferEmpty')) $ return ()+ -- this invariant guarantees we can always make forward progress+ -- and that therefore a BufferError is impossible++ let flush = if null inChunks then Stream.Finish else Stream.NoFlush+ status <- Stream.deflate flush++ case status of+ Stream.Ok -> do+ outputBufferFull <- Stream.outputBufferFull+ if outputBufferFull+ then do (outFPtr, offset, length) <- Stream.popOutputBuffer+ outChunks <- Stream.unsafeInterleave (fillBuffers inChunks)+ return (Base.PS outFPtr offset length : outChunks)+ else do fillBuffers inChunks++ Stream.StreamEnd -> do+ inputBufferEmpty <- Stream.inputBufferEmpty+ assert inputBufferEmpty $ return ()+ outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable+ if outputBufferBytesAvailable > 0+ then do (outFPtr, offset, length) <- Stream.popOutputBuffer+ Stream.finalise+ return (Base.PS outFPtr offset length : [])+ else do Stream.finalise+ return []+ Stream.BufferError -> fail "BufferError should be impossible!"+ Stream.NeedDict -> fail "NeedDict is impossible!"+++{-# NOINLINE decompressFull #-}+decompressFull+ :: Stream.Format+ -> Stream.WindowBits+ -> Lazy.ByteString+ -> Lazy.ByteString+decompressFull format bits (LPS chunks) =+ Stream.run $ do+ Stream.inflateInit format bits+ case chunks of+ [] -> liftM LPS (fillBuffers [])+ (Base.PS inFPtr offset length : chunks') -> do+ Stream.pushInputBuffer inFPtr offset length+ liftM LPS (fillBuffers chunks')++ where+ outChunkSize :: Int+ outChunkSize = 32 * 1024 - 16++ -- we flick between two states:+ -- * where one or other buffer is empty+ -- - in which case we refill one or both+ -- * where both buffers are non-empty+ -- - in which case we compress until a buffer is empty++ fillBuffers ::+ [Strict.ByteString]+ -> Stream [Strict.ByteString]+ fillBuffers inChunks = do++ -- in this state there are two possabilities:+ -- * no outbut buffer space is available+ -- - in which case we must make more available+ -- * no input buffer is available+ -- - in which case we must supply more+ inputBufferEmpty <- Stream.inputBufferEmpty+ outputBufferFull <- Stream.outputBufferFull++ assert (inputBufferEmpty || outputBufferFull) $ return ()++ when outputBufferFull $ do+ outFPtr <- Stream.unsafeLiftIO (Base.mallocByteString outChunkSize)+ Stream.pushOutputBuffer outFPtr 0 outChunkSize++ if inputBufferEmpty+ then case inChunks of+ [] -> drainBuffers []+ (Base.PS inFPtr offset length : inChunks') -> do+ Stream.pushInputBuffer inFPtr offset length+ drainBuffers inChunks'+ else drainBuffers inChunks+++ drainBuffers ::+ [Strict.ByteString]+ -> Stream [Strict.ByteString]+ drainBuffers inChunks = do++ inputBufferEmpty' <- Stream.inputBufferEmpty+ outputBufferFull' <- Stream.outputBufferFull+ assert(not outputBufferFull'+ && (null inChunks || not inputBufferEmpty')) $ return ()+ -- this invariant guarantees we can always make forward progress or at+ -- least if a BufferError does occur that it must be due to a premature EOF++ status <- Stream.inflate Stream.NoFlush++ case status of+ Stream.Ok -> do+ outputBufferFull <- Stream.outputBufferFull+ if outputBufferFull+ then do (outFPtr, offset, length) <- Stream.popOutputBuffer+ outChunks <- Stream.unsafeInterleave (fillBuffers inChunks)+ return (Base.PS outFPtr offset length : outChunks)+ else do fillBuffers inChunks++ Stream.StreamEnd -> do+ -- Note that there may be input bytes still available if the stream+ -- is embeded in some other data stream. Here we just silently discard+ -- any trailing data.+ outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable+ if outputBufferBytesAvailable > 0+ then do (outFPtr, offset, length) <- Stream.popOutputBuffer+ Stream.finalise+ return (Base.PS outFPtr offset length : [])+ else do Stream.finalise+ return []+ Stream.BufferError -> fail "premature end of compressed stream"+ Stream.NeedDict -> fail "compressed stream needs a custom dictionary"
+ Codec/Compression/Zlib/Raw.hs view
@@ -0,0 +1,41 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (c) 2006 Duncan Coutts+-- License : BSD-style+--+-- Maintainer : duncan.coutts@worc.ox.ac.uk+-- Stability : experimental+-- Portability : portable (H98 + FFI)+--+-- Compression and decompression of data streams in the raw deflate format.+--+-- The format is described in detail in RFC #1951:+-- <http://www.ietf.org/rfc/rfc1951.txt>+--+-- See also the zlib home page: <http://zlib.net/>+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib.Raw (+ + -- * Compression+ compress,+ compressWith,+ CompressionLevel(..),+ + -- * Decompression+ decompress+ + ) where++import Data.ByteString.Lazy (ByteString)++import Codec.Compression.Zlib.Internal as Internal++decompress :: ByteString -> ByteString+decompress = Internal.decompressDefault Raw++compress :: ByteString -> ByteString+compress = Internal.compressDefault Raw DefaultCompression++compressWith ::CompressionLevel -> ByteString -> ByteString+compressWith = Internal.compressDefault Raw
+ Codec/Compression/Zlib/Stream.hsc view
@@ -0,0 +1,604 @@+-----------------------------------------------------------------------------+-- |+-- Copyright : (c) 2006 Duncan Coutts+-- License : BSD-style+--+-- Maintainer : duncan.coutts@worc.ox.ac.uk+-- Stability : experimental+-- Portability : portable (H98 + FFI)+--+-- Zlib wrapper layer+--+-----------------------------------------------------------------------------+module Codec.Compression.Zlib.Stream (++ -- * The Zlib state monad+ Stream,+ run,+ unsafeInterleave,+ unsafeLiftIO,+ finalise,++ -- * Initialisation+ deflateInit, + inflateInit,++ -- ** Initialisation parameters+ Format(..),+ CompressionLevel(..),+ Method(..),+ WindowBits(..),+ MemoryLevel(..),+ CompressionStrategy(..),++ -- * The buisness+ deflate,+ inflate,+ Status(..),+ Flush(..),++ -- * Buffer management+ -- ** Input buffer+ pushInputBuffer,+ inputBufferEmpty,++ -- ** Output buffer+ pushOutputBuffer,+ popOutputBuffer,+ outputBufferBytesAvailable,+ outputBufferSpaceRemaining,+ outputBufferFull,++ -- * Debugging+ consistencyCheck,+ dump,+ trace,++ ) where++import Foreign+import Foreign.C+import Data.ByteString.Base+import System.IO.Unsafe (unsafeInterleaveIO)+import System.IO (hPutStrLn, stderr)+import Control.Monad (liftM)+import Control.Exception (assert)++import Prelude hiding (length)++#include <zlib.h>+++pushInputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream ()+pushInputBuffer inBuf' offset length = do++ -- must not push a new input buffer if the last one is not used up+ inAvail <- getInAvail+ assert (inAvail == 0) $ return ()++ -- Now that we're setting a new input buffer, we can be sure that zlib no+ -- longer has a reference to the old one. Therefore this is the last point+ -- at which the old buffer had to be retained. It's safe to release now.+ inBuf <- getInBuf + unsafeLiftIO $ touchForeignPtr inBuf ++ -- now set the available input buffer ptr and length+ setInBuf inBuf'+ setInAvail length+ setInNext (unsafeForeignPtrToPtr inBuf' `plusPtr` offset)+ -- Note the 'unsafe'. We are passing the raw ptr inside inBuf' to zlib.+ -- To make this safe we need to hold on to the ForeignPtr for at least as+ -- long as zlib is using the underlying raw ptr.+++inputBufferEmpty :: Stream Bool+inputBufferEmpty = getInAvail >>= return . (==0)+++pushOutputBuffer :: ForeignPtr Word8 -> Int -> Int -> Stream ()+pushOutputBuffer outBuf' offset length = do++ --must not push a new buffer if there is still data in the old one+ outAvail <- getOutAvail+ assert (outAvail == 0) $ return ()+ -- Note that there may still be free space in the output buffer, that's ok,+ -- you might not want to bother completely filling the output buffer say if+ -- there's only a few free bytes left.++ outBuf <- getOutBuf+ unsafeLiftIO $ touchForeignPtr outBuf++ -- now set the available input buffer ptr and length+ setOutBuf outBuf'+ setOutFree length+ setOutNext (unsafeForeignPtrToPtr outBuf' `plusPtr` offset)++ setOutOffset offset+ setOutAvail 0+++-- get that part of the output buffer that is currently full+-- (might be 0, use outputBufferBytesAvailable to check)+-- this may leave some space remaining in the buffer, use+-- outputBufferSpaceRemaining to check.+popOutputBuffer :: Stream (ForeignPtr Word8, Int, Int)+popOutputBuffer = do++ outBuf <- getOutBuf+ outOffset <- getOutOffset+ outAvail <- getOutAvail++ -- there really should be something to pop, otherwise it's silly+ assert (outAvail > 0) $ return ()++ setOutOffset (outOffset + outAvail)+ setOutAvail 0++ return (outBuf, outOffset, outAvail)+++-- this is the number of bytes available in the output buffer+outputBufferBytesAvailable :: Stream Int+outputBufferBytesAvailable = getOutAvail+++-- you needen't get all the output immediately, you can continue until+-- there is no more output space available, this tells you that amount+outputBufferSpaceRemaining :: Stream Int+outputBufferSpaceRemaining = getOutFree+++-- you only need to supply a new buffer when there is no more output buffer+-- space remaining+outputBufferFull :: Stream Bool+outputBufferFull = getOutFree >>= return . (==0)+++-- you can only run this when the output buffer is not empty+-- you can run it when the input buffer is empty but it doesn't do anything+-- after running deflate either the output buffer will be full+-- or the input buffer will be empty (or both)+deflate :: Flush -> Stream Status+deflate flush = do++ outFree <- getOutFree++ -- deflate needs free space in the output buffer+ assert (outFree > 0) $ return ()++ result <- deflate_ flush+ outFree' <- getOutFree+ + -- number of bytes of extra output there is available as a result of+ -- the call to deflate:+ let outExtra = outFree - outFree'+ + outAvail <- getOutAvail+ setOutAvail (outAvail + outExtra)+ return result+++inflate :: Flush -> Stream Status+inflate flush = do++ outFree <- getOutFree++ -- inflate needs free space in the output buffer+ assert (outFree > 0) $ return ()++ result <- inflate_ flush+ outFree' <- getOutFree++ -- number of bytes of extra output there is available as a result of+ -- the call to inflate:+ let outExtra = outFree - outFree'++ outAvail <- getOutAvail+ setOutAvail (outAvail + outExtra)+ return result+++----------------------------+-- Stream monad+--++newtype Stream a = Z {+ unZ :: ForeignPtr StreamState+ -> ForeignPtr Word8+ -> ForeignPtr Word8+ -> Int -> Int+ -> IO (ForeignPtr Word8+ ,ForeignPtr Word8+ ,Int, Int, a)+ }++instance Monad Stream where+ (>>=) = thenZ+-- m >>= f = (m `thenZ` \a -> consistencyCheck `thenZ_` returnZ a) `thenZ` f+ (>>) = thenZ_+ return = returnZ+ fail = (finalise >>) . failZ++returnZ :: a -> Stream a+returnZ a = Z $ \_ inBuf outBuf outOffset outLength ->+ return (inBuf, outBuf, outOffset, outLength, a)+{-# INLINE returnZ #-}++thenZ :: Stream a -> (a -> Stream b) -> Stream b+thenZ (Z m) f =+ Z $ \stream inBuf outBuf outOffset outLength ->+ m stream inBuf outBuf outOffset outLength >>=+ \(inBuf', outBuf', outOffset', outLength', a) ->+ unZ (f a) stream inBuf' outBuf' outOffset' outLength'+{-# INLINE thenZ #-}++thenZ_ :: Stream a -> Stream b -> Stream b+thenZ_ (Z m) f =+ Z $ \stream inBuf outBuf outOffset outLength ->+ m stream inBuf outBuf outOffset outLength >>=+ \(inBuf', outBuf', outOffset', outLength', _) ->+ unZ f stream inBuf' outBuf' outOffset' outLength'+{-# INLINE thenZ_ #-}++failZ :: String -> Stream a+failZ msg = Z (\_ _ _ _ _ -> fail ("Codec.Compression.Zlib: " ++ msg))++{-# NOINLINE run #-}+run :: Stream a -> a+run (Z m) = unsafePerformIO $ do+ ptr <- mallocBytes (#{const sizeof(z_stream)})+ #{poke z_stream, next_in} ptr nullPtr+ #{poke z_stream, avail_in} ptr (0 :: CUInt)+ #{poke z_stream, next_out} ptr nullPtr+ #{poke z_stream, avail_out} ptr (0 :: CUInt)+ #{poke z_stream, zalloc} ptr nullPtr+ #{poke z_stream, zfree} ptr nullPtr+ #{poke z_stream, opaque} ptr nullPtr+ stream <- newForeignPtr_ ptr+ (_,_,_,_,a) <- m stream nullForeignPtr nullForeignPtr 0 0+ return a++unsafeLiftIO :: IO a -> Stream a+unsafeLiftIO m = Z $ \_stream inBuf outBuf outOffset outLength -> do+ a <- m+ return (inBuf, outBuf, outOffset, outLength, a)++-- It's unsafe because we discard the values here, so if you mutate anything+-- between running this and forcing the result then you'll get an inconsistent+-- stream state.+unsafeInterleave :: Stream a -> Stream a+unsafeInterleave (Z m) = Z $ \stream inBuf outBuf outOffset outLength -> do+ res <- unsafeInterleaveIO (m stream inBuf outBuf outOffset outLength)+ let select (_,_,_,_,a) = a+ return (inBuf, outBuf, outOffset, outLength, select res)++getStreamState :: Stream (ForeignPtr StreamState)+getStreamState = Z $ \stream inBuf outBuf outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, stream)++getInBuf :: Stream (ForeignPtr Word8)+getInBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, inBuf)++getOutBuf :: Stream (ForeignPtr Word8)+getOutBuf = Z $ \_stream inBuf outBuf outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, outBuf)++getOutOffset :: Stream Int+getOutOffset = Z $ \_stream inBuf outBuf outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, outOffset)++getOutAvail :: Stream Int+getOutAvail = Z $ \_stream inBuf outBuf outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, outLength)++setInBuf :: ForeignPtr Word8 -> Stream ()+setInBuf inBuf = Z $ \_stream _ outBuf outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, ())++setOutBuf :: ForeignPtr Word8 -> Stream ()+setOutBuf outBuf = Z $ \_stream inBuf _ outOffset outLength -> do+ return (inBuf, outBuf, outOffset, outLength, ())++setOutOffset :: Int -> Stream ()+setOutOffset outOffset = Z $ \_stream inBuf outBuf _ outLength -> do+ return (inBuf, outBuf, outOffset, outLength, ())++setOutAvail :: Int -> Stream ()+setOutAvail outLength = Z $ \_stream inBuf outBuf outOffset _ -> do+ return (inBuf, outBuf, outOffset, outLength, ())++----------------------------+-- Debug stuff+--++trace :: String -> Stream ()+trace = unsafeLiftIO . hPutStrLn stderr++dump :: Stream ()+dump = do+ inNext <- getInNext+ inAvail <- getInAvail++ outNext <- getOutNext+ outFree <- getOutFree+ outAvail <- getOutAvail+ outOffset <- getOutOffset++ unsafeLiftIO $ hPutStrLn stderr $+ "Stream {\n" +++ " inNext = " ++ show inNext ++ ",\n" +++ " inAvail = " ++ show inAvail ++ ",\n" +++ "\n" +++ " outNext = " ++ show outNext ++ ",\n" +++ " outFree = " ++ show outFree ++ ",\n" +++ " outAvail = " ++ show outAvail ++ ",\n" +++ " outOffset = " ++ show outOffset ++ "\n" +++ "}"++ consistencyCheck++consistencyCheck :: Stream ()+consistencyCheck = do++ outBuf <- getOutBuf+ outOffset <- getOutOffset+ outAvail <- getOutAvail+ outNext <- getOutNext++ let outBufPtr = unsafeForeignPtrToPtr outBuf++ assert (outBufPtr `plusPtr` (outOffset + outAvail) == outNext) $ return ()+++----------------------------+-- zlib wrapper layer+--++data Status =+ Ok+ | StreamEnd+ | NeedDict+ | BufferError -- ^ No progress was possible or there was not enough room in+ -- the output buffer when 'Finish' is used. Note that+ -- 'BuferError' is not fatal, and 'inflate' can be called+ -- again with more input and more output space to continue.++instance Enum Status where+ toEnum (#{const Z_OK}) = Ok+ toEnum (#{const Z_STREAM_END}) = StreamEnd+ toEnum (#{const Z_NEED_DICT}) = NeedDict+ toEnum (#{const Z_BUF_ERROR}) = BufferError+ toEnum other = error ("unexpected zlib status: " ++ show other)++isFatalError :: CInt -> Bool+isFatalError n | n >= 0 = False+isFatalError (#{const Z_BUF_ERROR}) = False+isFatalError _ = True++throwError :: Stream a+throwError = do+ msg <- withStreamPtr (#{peek z_stream, msg})+ msg' <- unsafeLiftIO (peekCString msg)+ fail msg'++data Flush =+ NoFlush+ | SyncFlush+ | FullFlush+ | Finish+ | Block++instance Enum Flush where+ fromEnum NoFlush = #{const Z_NO_FLUSH}+ fromEnum SyncFlush = #{const Z_SYNC_FLUSH}+ fromEnum FullFlush = #{const Z_FULL_FLUSH}+ fromEnum Finish = #{const Z_FINISH}+ fromEnum Block = #{const Z_BLOCK}++data Format =+ GZip -- ^ Encode or decode with the gzip header format.+ | Zlib -- ^ Encode or decode with the zlib header format.+ | Raw -- ^ Encode or decode a raw data stream without any header.+ | GZipOrZlib -- ^ Enable zlib or gzip decoding with automatic header+ -- detection. This only makes sense for decompression.++-- | The compression method+data Method = Deflated -- ^ \'Deflate\' is the only one supported in this+ -- version of zlib.++instance Enum Method where+ fromEnum Deflated = #{const Z_DEFLATED}++-- | Control amount of compression. This is a trade-off between the amount+-- of compression and the time and memory required to do the compression.+data CompressionLevel = + DefaultCompression -- ^ The default compression level is 6 (that is, + -- biased towards high compression at expense of speed).+ | NoCompression -- ^ No compression, just a block copy.+ | BestSpeed -- ^ The fastest compression method (less compression) + | BestCompression -- ^ The slowest compression method (best compression).+ | CompressionLevel Int -- ^ A specific compression level between 1 and 9.++instance Enum CompressionLevel where+ fromEnum DefaultCompression = -1+ fromEnum NoCompression = 0+ fromEnum BestSpeed = 1+ fromEnum BestCompression = 9+ fromEnum (CompressionLevel n)+ | n >= 1 && n <= 9 = n+ | otherwise = error "CompressLevel must be in the range 1..9"++data WindowBits = DefaultWindowBits+ | WindowBits Int++windowBits :: Format -> WindowBits-> Int+windowBits format bits = (formatModifier format) (checkWindowBits bits)+ where checkWindowBits DefaultWindowBits = 15+ checkWindowBits (WindowBits n)+ | n >= 8 && n <= 15 = n+ | otherwise = error "WindowBits must be in the range 8..15"+ formatModifier Zlib = id+ formatModifier GZip = (+16)+ formatModifier GZipOrZlib = (+32)+ formatModifier Raw = negate++-- | The 'MemoryLevel' parameter specifies how much memory should be allocated+-- for the internal compression state.+--+data MemoryLevel =+ DefaultMemoryLevel -- ^ The default. (Equivalent to @'MemoryLevel' 8@)+ | MinMemoryLevel -- ^ Use minimum memory. This is slow and reduces the+ -- compression ratio. (Equivalent to @'MemoryLevel' 1@)+ | MaxMemoryLevel -- ^ Use maximum memory for optimal compression speed.+ -- (Equivalent to @'MemoryLevel' 9@)+ | MemoryLevel Int -- ^ Use a specific level in the range 1..9++instance Enum MemoryLevel where+ fromEnum DefaultMemoryLevel = 8+ fromEnum MinMemoryLevel = 1+ fromEnum MaxMemoryLevel = 9+ fromEnum (MemoryLevel n)+ | n >= 1 && n <= 9 = n+ | otherwise = error "MemoryLevel must be in the range 1..9"+++-- | The strategy parameter is used to tune the compression algorithm.+--+-- The strategy parameter only affects the compression ratio but not the+-- correctness of the compressed output even if it is not set appropriately.+--+data CompressionStrategy =+ DefaultStrategy -- ^ Use the 'DefaultStrategy' for normal data.+ | Filtered -- ^ Use 'Filtered' for data produced by a filter (or+ -- predictor). Filtered data consists mostly of small+ -- values with a somewhat random distribution. In this+ -- case, the compression algorithm is tuned to compress+ -- them better. The effect of Z_FILTERED is to force more+ -- Huffman coding and less string matching; it is+ -- somewhat intermediate between 'DefaultStrategy' and+ -- 'HuffmanOnly'. + | HuffmanOnly -- ^ Use 'HuffmanOnly' to force Huffman encoding only (no+ -- string match). + | RLE -- ^ Use 'RLE' to limit match distances to one (run-length+ -- encoding). 'RLE' is designed to be almost as fast as+ -- 'HuffmanOnly', but give better compression for PNG+ -- image data.+ | Fixed -- ^ 'Fixed' prevents the use of dynamic Huffman codes,+ -- allowing for a simpler decoder for special applications.++instance Enum CompressionStrategy where+ fromEnum DefaultStrategy = #{const Z_DEFAULT_STRATEGY}+ fromEnum Filtered = #{const Z_FILTERED}+ fromEnum HuffmanOnly = #{const Z_HUFFMAN_ONLY}+ fromEnum RLE = #{const Z_RLE}+ fromEnum Fixed = #{const Z_FIXED}++withStreamPtr :: (Ptr StreamState -> IO a) -> Stream a+withStreamPtr f = do+ stream <- getStreamState+ unsafeLiftIO (withForeignPtr stream f)++setInAvail :: Int -> Stream ()+setInAvail val = withStreamPtr $ \ptr ->+ #{poke z_stream, avail_in} ptr (fromIntegral val :: CUInt)++getInAvail :: Stream Int+getInAvail = liftM (fromIntegral :: CUInt -> Int) $+ withStreamPtr (#{peek z_stream, avail_in})++setInNext :: Ptr Word8 -> Stream ()+setInNext val = withStreamPtr (\ptr -> #{poke z_stream, next_in} ptr val)++getInNext :: Stream (Ptr Word8)+getInNext = withStreamPtr (#{peek z_stream, next_in})++setOutFree :: Int -> Stream ()+setOutFree val = withStreamPtr $ \ptr ->+ #{poke z_stream, avail_out} ptr (fromIntegral val :: CUInt)++getOutFree :: Stream Int+getOutFree = liftM (fromIntegral :: CUInt -> Int) $+ withStreamPtr (#{peek z_stream, avail_out})++setOutNext :: Ptr Word8 -> Stream ()+setOutNext val = withStreamPtr (\ptr -> #{poke z_stream, next_out} ptr val)++getOutNext :: Stream (Ptr Word8)+getOutNext = withStreamPtr (#{peek z_stream, next_out})++inflateInit :: Format -> WindowBits -> Stream ()+inflateInit format bits = do+ err <- withStreamPtr $ \ptr ->+ c_inflateInit2 ptr (fromIntegral (windowBits format bits))+ if isFatalError err+ then throwError+ else do stream <- getStreamState+ unsafeLiftIO $ addForeignPtrFinalizer c_inflateEnd stream++deflateInit :: Format+ -> CompressionLevel+ -> Method+ -> WindowBits+ -> MemoryLevel+ -> CompressionStrategy+ -> Stream ()+deflateInit format compLevel method bits memLevel strategy = do+ err <- withStreamPtr $ \ptr ->+ c_deflateInit2 ptr+ (fromIntegral (fromEnum compLevel))+ (fromIntegral (fromEnum method))+ (fromIntegral (windowBits format bits))+ (fromIntegral (fromEnum memLevel))+ (fromIntegral (fromEnum strategy))+ if isFatalError err+ then throwError+ else do stream <- getStreamState+ unsafeLiftIO $ addForeignPtrFinalizer c_deflateEnd stream++inflate_ :: Flush -> Stream Status+inflate_ flush = do+ err <- withStreamPtr (\ptr -> c_inflate ptr (fromIntegral (fromEnum flush)))+ if isFatalError err+ then throwError+ else return (toEnum (fromIntegral err))++deflate_ :: Flush -> Stream Status+deflate_ flush = do+ err <- withStreamPtr (\ptr -> c_deflate ptr (fromIntegral (fromEnum flush)))+ if isFatalError err+ then throwError+ else return (toEnum (fromIntegral err))++-- | This never needs to be used as the stream's resources will be released+-- automatically when no longer needed, however this can be used to release+-- them early. Only use this when you can guarantee that the stream will no+-- longer be needed, for example if an error occurs or if the stream ends.+--+finalise :: Stream ()+finalise = getStreamState >>= unsafeLiftIO . finalizeForeignPtr++----------------------+-- The foreign imports++data StreamState = StreamState ()++foreign import ccall unsafe "zlib.h inflateInit2"+ c_inflateInit2 :: Ptr StreamState -> CInt -> IO CInt++foreign import ccall unsafe "zlib.h inflate"+ c_inflate :: Ptr StreamState -> CInt -> IO CInt++foreign import ccall unsafe "zlib.h &inflateEnd"+ c_inflateEnd :: FinalizerPtr StreamState+++foreign import ccall unsafe "zlib.h deflateInit2"+ c_deflateInit2 :: Ptr StreamState+ -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt++foreign import ccall unsafe "zlib.h deflate"+ c_deflate :: Ptr StreamState -> CInt -> IO CInt++foreign import ccall unsafe "zlib.h &deflateEnd"+ c_deflateEnd :: FinalizerPtr StreamState
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ zlib.cabal view
@@ -0,0 +1,17 @@+name: zlib+version: 0.2+copyright: (c) 2006 Duncan Coutts+build-depends: base, fps+license: BSD3+author: Duncan Coutts <duncan.coutts@worc.ox.ac.uk>+maintainer: Duncan Coutts <duncan.coutts@worc.ox.ac.uk>+synopsis: Compression and decompression in the gzip and zlib formats+exposed-modules: Codec.Compression.GZip,+ Codec.Compression.Zlib,+ Codec.Compression.Zlib.Raw,+ Codec.Compression.Zlib.Internal+other-modules: Codec.Compression.Zlib.Stream+extensions: ForeignFunctionInterface+includes: zlib.h+extra-libraries: z+ghc-options: -fvia-C -Wall