diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -1,35 +1,35 @@ -import Codec.Compression.Zlib(ZlibDecoder(..), decompressIncremental) -import Control.Monad(unless) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Time.Clock(getCurrentTime, diffUTCTime) -import Prelude hiding (readFile, writeFile) - -main :: IO () -main = - do zbstr <- L.readFile "test/test-cases/tor-list.z" - goldbstr <- L.readFile "test/test-cases/tor-list.gold" - before <- getCurrentTime - runDecompression (L.toChunks zbstr) goldbstr decompressIncremental - after <- getCurrentTime - putStrLn ("Decompression took " ++ show (diffUTCTime after before)) - -runDecompression :: [S.ByteString] -> L.ByteString -> ZlibDecoder -> IO () -runDecompression ls real decoder = - case decoder of - Done -> - do unless (null ls) $ - fail "ERROR: Finished decompression with data left." - unless (L.null real) $ - fail "ERROR: Did not completely decompress file." - return () - DecompError e -> - fail ("ERROR: " ++ show e) - NeedMore f | (x:rest) <- ls -> runDecompression rest real (f x) - | otherwise -> - fail "ERROR: Ran out of data mid-decompression." - Chunk c m -> - let (realfirst, realrest) = L.splitAt (L.length c) real - in if realfirst == c - then runDecompression ls realrest m - else fail "Mismatch in decompression" +import Codec.Compression.Zlib(ZlibDecoder(..), decompressIncremental) +import Control.Monad(unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Time.Clock(getCurrentTime, diffUTCTime) +import Prelude hiding (readFile, writeFile) + +main :: IO () +main = + do zbstr <- L.readFile "test/test-cases/tor-list.z" + goldbstr <- L.readFile "test/test-cases/tor-list.gold" + before <- getCurrentTime + runDecompression (L.toChunks zbstr) goldbstr decompressIncremental + after <- getCurrentTime + putStrLn ("Decompression took " ++ show (diffUTCTime after before)) + +runDecompression :: [S.ByteString] -> L.ByteString -> ZlibDecoder -> IO () +runDecompression ls real decoder = + case decoder of + Done -> + do unless (null ls) $ + fail "ERROR: Finished decompression with data left." + unless (L.null real) $ + fail "ERROR: Did not completely decompress file." + return () + DecompError e -> + fail ("ERROR: " ++ show e) + NeedMore f | (x:rest) <- ls -> runDecompression rest real (f x) + | otherwise -> + fail "ERROR: Ran out of data mid-decompression." + Chunk c m -> + let (realfirst, realrest) = L.splitAt (L.length c) real + in if realfirst == c + then runDecompression ls realrest m + else fail "Mismatch in decompression" diff --git a/Deflate.hs b/Deflate.hs --- a/Deflate.hs +++ b/Deflate.hs @@ -1,40 +1,40 @@ -import Codec.Compression.Zlib(ZlibDecoder(..), decompressIncremental) -import Control.Monad(unless) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.List(isSuffixOf) -import Prelude hiding (readFile, writeFile) -import System.Environment(getArgs) -import System.IO(IOMode(..), Handle, openFile, hClose) - -main :: IO () -main = - do args <- getArgs - case args of - [ifile] -> - if ".z" `isSuffixOf` ifile - then do bstr <- L.readFile ifile - let outname = take (length ifile - 2) ifile - hndl <- openFile outname WriteMode - runDecompression hndl (L.toChunks bstr) decompressIncremental - else putStrLn "Unexpected file name." - _ -> - putStrLn "USAGE: deflate [filename]" - -runDecompression :: Handle -> [S.ByteString] -> ZlibDecoder -> IO () -runDecompression hndl ls decoder = - case decoder of - Done -> - do unless (null ls) $ - putStrLn "WARNING: Finished decompression with data left." - hClose hndl - DecompError e -> - do putStrLn ("ERROR: " ++ show e) - hClose hndl - NeedMore f | (x:rest) <- ls -> runDecompression hndl rest (f x) - | otherwise -> - do putStrLn "ERROR: Ran out of data mid-decompression." - hClose hndl - Chunk c m -> - do L.hPut hndl c - runDecompression hndl ls m +import Codec.Compression.Zlib(ZlibDecoder(..), decompressIncremental) +import Control.Monad(unless) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.List(isSuffixOf) +import Prelude hiding (readFile, writeFile) +import System.Environment(getArgs) +import System.IO(IOMode(..), Handle, openFile, hClose) + +main :: IO () +main = + do args <- getArgs + case args of + [ifile] -> + if ".z" `isSuffixOf` ifile + then do bstr <- L.readFile ifile + let outname = take (length ifile - 2) ifile + hndl <- openFile outname WriteMode + runDecompression hndl (L.toChunks bstr) decompressIncremental + else putStrLn "Unexpected file name." + _ -> + putStrLn "USAGE: deflate [filename]" + +runDecompression :: Handle -> [S.ByteString] -> ZlibDecoder -> IO () +runDecompression hndl ls decoder = + case decoder of + Done -> + do unless (null ls) $ + putStrLn "WARNING: Finished decompression with data left." + hClose hndl + DecompError e -> + do putStrLn ("ERROR: " ++ show e) + hClose hndl + NeedMore f | (x:rest) <- ls -> runDecompression hndl rest (f x) + | otherwise -> + do putStrLn "ERROR: Ran out of data mid-decompression." + hClose hndl + Chunk c m -> + do L.hPut hndl c + runDecompression hndl ls m diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c) 2010 Galois Inc. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - * Neither the name of Galois, Inc. nor the names of its contributors - may be used to endorse or promote products derived from this - software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c) 2010 Galois Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + + * Neither the name of Galois, Inc. nor the names of its contributors + may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/pure-zlib.cabal b/pure-zlib.cabal --- a/pure-zlib.cabal +++ b/pure-zlib.cabal @@ -1,90 +1,90 @@ -name: pure-zlib -version: 0.6.5 -synopsis: A Haskell-only implementation of zlib / DEFLATE -homepage: http://github.com/GaloisInc/pure-zlib -license: BSD3 -license-file: LICENSE -author: Adam Wick -maintainer: awick@galois.com -category: Codec -build-type: Simple -cabal-version: >=1.18 -description: A Haskell-only implementation of the zlib / DEFLATE - protocol. Currently only implements the decompression - algorithm. -extra-source-files: test/test-cases/*.z, - test/test-cases/*.gold - -library - default-language: Haskell2010 - ghc-options: -Wall - hs-source-dirs: src - build-depends: - array >= 0.4 && < 0.9, - base >= 4.6 && < 5.0, - base-compat >= 0.9.1 && < 0.11, - bytestring >= 0.10 && < 0.11, - bytestring-builder >= 0.10 && < 0.11, - containers >= 0.5 && < 0.7, - fingertree >= 0.1 && < 0.3 - if !impl(ghc >= 8.0) - build-depends: semigroups == 0.18.* - exposed-modules: - Codec.Compression.Zlib, - Codec.Compression.Zlib.Adler32, - Codec.Compression.Zlib.Deflate, - Codec.Compression.Zlib.HuffmanTree, - Codec.Compression.Zlib.Monad, - Codec.Compression.Zlib.OutputWindow - default-extensions: - BangPatterns, - DeriveDataTypeable, - GeneralizedNewtypeDeriving, - MultiParamTypeClasses, - MultiWayIf - -executable deflate - default-language: Haskell2010 - main-is: Deflate.hs - ghc-options: -Wall - build-depends: - base >= 4.6 && < 5.0, - base-compat >= 0.9.1 && < 0.11, - bytestring >= 0.10 && < 0.11, - pure-zlib - -test-suite test-zlib - type: exitcode-stdio-1.0 - main-is: Test.hs - ghc-options: -Wall - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -fno-warn-orphans - build-depends: - base >= 4.6 && < 5.0, - base-compat >= 0.9.1 && < 0.11, - bytestring >= 0.10 && < 0.11, - filepath >= 1.4.1 && < 1.6, - HUnit >= 1.2 && < 1.7, - QuickCheck >= 2.7 && < 2.14, - pure-zlib, - tasty >= 0.11.0.4 && < 1.3, - tasty-hunit >= 0.9.2 && < 0.11, - tasty-quickcheck >= 0.8.4 && < 0.11 - -benchmark bench-zlib - type: exitcode-stdio-1.0 - main-is: Benchmark.hs - default-language: Haskell2010 - ghc-options: -Wall - build-depends: - base >= 4.6 && < 5.0, - base-compat >= 0.9.1 && < 0.11, - bytestring >= 0.10 && < 0.11, - pure-zlib, - time >= 1.4.2 && < 1.11 - -source-repository head - type: git - location: git://github.com/GaloisInc/pure-zlib.git - +name: pure-zlib +version: 0.6.6 +synopsis: A Haskell-only implementation of zlib / DEFLATE +homepage: http://github.com/GaloisInc/pure-zlib +license: BSD3 +license-file: LICENSE +author: Adam Wick +maintainer: awick@galois.com +category: Codec +build-type: Simple +cabal-version: 1.18 +description: A Haskell-only implementation of the zlib / DEFLATE + protocol. Currently only implements the decompression + algorithm. +extra-source-files: test/test-cases/*.z, + test/test-cases/*.gold + +library + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + build-depends: + array >= 0.4 && < 0.9, + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + bytestring-builder >= 0.10 && < 0.11, + containers >= 0.5 && < 0.7, + fingertree >= 0.1 && < 0.3 + if !impl(ghc >= 8.0) + build-depends: semigroups == 0.18.* + exposed-modules: + Codec.Compression.Zlib, + Codec.Compression.Zlib.Adler32, + Codec.Compression.Zlib.Deflate, + Codec.Compression.Zlib.HuffmanTree, + Codec.Compression.Zlib.Monad, + Codec.Compression.Zlib.OutputWindow + default-extensions: + BangPatterns, + DeriveDataTypeable, + GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + MultiWayIf + +executable deflate + default-language: Haskell2010 + main-is: Deflate.hs + ghc-options: -Wall + build-depends: + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + pure-zlib + +test-suite test-zlib + type: exitcode-stdio-1.0 + main-is: Test.hs + ghc-options: -Wall + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -fno-warn-orphans + build-depends: + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + filepath >= 1.4.1 && < 1.6, + HUnit >= 1.2 && < 1.7, + QuickCheck >= 2.7 && < 2.14, + pure-zlib, + tasty >= 0.11.0.4 && < 1.3, + tasty-hunit >= 0.9.2 && < 0.11, + tasty-quickcheck >= 0.8.4 && < 0.11 + +benchmark bench-zlib + type: exitcode-stdio-1.0 + main-is: Benchmark.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >= 4.6 && < 5.0, + base-compat >= 0.9.1 && < 0.11, + bytestring >= 0.10 && < 0.11, + pure-zlib, + time >= 1.4.2 && < 1.11 + +source-repository head + type: git + location: git://github.com/GaloisInc/pure-zlib.git + diff --git a/src/Codec/Compression/Zlib.hs b/src/Codec/Compression/Zlib.hs --- a/src/Codec/Compression/Zlib.hs +++ b/src/Codec/Compression/Zlib.hs @@ -1,58 +1,58 @@ -{-# LANGUAGE MultiWayIf #-} -module Codec.Compression.Zlib( - DecompressionError(..) - , ZlibDecoder(NeedMore, Chunk, Done, DecompError) - , decompress - , decompressIncremental - ) - where - -import Codec.Compression.Zlib.Deflate(inflate) -import Codec.Compression.Zlib.Monad(ZlibDecoder(..), DeflateM, - DecompressionError(..), - runDeflateM, raise, nextByte) -import Control.Monad(unless, when, replicateM_) -import Data.Bits((.|.), (.&.), shiftL, shiftR, testBit) -import Data.ByteString.Builder(lazyByteString,toLazyByteString) -import qualified Data.ByteString.Lazy as L -import Data.Semigroup ((<>)) -import Data.Word(Word16) -import Prelude() -import Prelude.Compat - -decompressIncremental :: ZlibDecoder -decompressIncremental = runDeflateM inflateWithHeaders - -decompress :: L.ByteString -> Either DecompressionError L.ByteString -decompress ifile = run decompressIncremental (L.toChunks ifile) mempty - where - run (NeedMore _) [] _ = - Left (DecompressionError "Ran out of data mid-decompression 2.") - run (NeedMore f) (first:rest) acc = - run (f first) rest acc - run (Chunk c m) ls acc = - run m ls (acc <> lazyByteString c) - run Done [] acc = - Right (toLazyByteString acc) - run Done (_:_) _ = - Left (DecompressionError "Finished with data remaining.") - run (DecompError e) _ _ = - Left e - -inflateWithHeaders :: DeflateM () -inflateWithHeaders = - do cmf <- nextByte - flg <- nextByte - let both = fromIntegral cmf `shiftL` 8 .|. fromIntegral flg - cm = cmf .&. 0x0f - cinfo = cmf `shiftR` 4 - fdict = testBit flg 5 --- flevel = flg `shiftR` 6 - unless ((both :: Word16) `mod` 31 == 0) $ - raise (HeaderError "Header checksum failed") - unless (cm == 8) $ - raise (HeaderError ("Bad compression method: " ++ show cm)) - unless (cinfo <= 7) $ - raise (HeaderError ("Window size too big: " ++ show cinfo)) - when fdict $ replicateM_ 4 nextByte -- just skip them for now (FIXME) - inflate +{-# LANGUAGE MultiWayIf #-} +module Codec.Compression.Zlib( + DecompressionError(..) + , ZlibDecoder(NeedMore, Chunk, Done, DecompError) + , decompress + , decompressIncremental + ) + where + +import Codec.Compression.Zlib.Deflate(inflate) +import Codec.Compression.Zlib.Monad(ZlibDecoder(..), DeflateM, + DecompressionError(..), + runDeflateM, raise, nextByte) +import Control.Monad(unless, when, replicateM_) +import Data.Bits((.|.), (.&.), shiftL, shiftR, testBit) +import Data.ByteString.Builder(lazyByteString,toLazyByteString) +import qualified Data.ByteString.Lazy as L +import Data.Semigroup ((<>)) +import Data.Word(Word16) +import Prelude() +import Prelude.Compat + +decompressIncremental :: ZlibDecoder +decompressIncremental = runDeflateM inflateWithHeaders + +decompress :: L.ByteString -> Either DecompressionError L.ByteString +decompress ifile = run decompressIncremental (L.toChunks ifile) mempty + where + run (NeedMore _) [] _ = + Left (DecompressionError "Ran out of data mid-decompression 2.") + run (NeedMore f) (first:rest) acc = + run (f first) rest acc + run (Chunk c m) ls acc = + run m ls (acc <> lazyByteString c) + run Done [] acc = + Right (toLazyByteString acc) + run Done (_:_) _ = + Left (DecompressionError "Finished with data remaining.") + run (DecompError e) _ _ = + Left e + +inflateWithHeaders :: DeflateM () +inflateWithHeaders = + do cmf <- nextByte + flg <- nextByte + let both = fromIntegral cmf `shiftL` 8 .|. fromIntegral flg + cm = cmf .&. 0x0f + cinfo = cmf `shiftR` 4 + fdict = testBit flg 5 +-- flevel = flg `shiftR` 6 + unless ((both :: Word16) `mod` 31 == 0) $ + raise (HeaderError "Header checksum failed") + unless (cm == 8) $ + raise (HeaderError ("Bad compression method: " ++ show cm)) + unless (cinfo <= 7) $ + raise (HeaderError ("Window size too big: " ++ show cinfo)) + when fdict $ replicateM_ 4 nextByte -- just skip them for now (FIXME) + inflate diff --git a/src/Codec/Compression/Zlib/Adler32.hs b/src/Codec/Compression/Zlib/Adler32.hs --- a/src/Codec/Compression/Zlib/Adler32.hs +++ b/src/Codec/Compression/Zlib/Adler32.hs @@ -1,34 +1,34 @@ -module Codec.Compression.Zlib.Adler32( - AdlerState - , initialAdlerState - , advanceAdler - , finalizeAdler - ) - where - -import Data.Bits(shiftL, (.|.)) -import Data.Word(Word8, Word16, Word32) - -data AdlerState = AdlerState { adlerA :: !Word16, adlerB :: !Word16 } - -initialAdlerState :: AdlerState -initialAdlerState = AdlerState 1 0 - -adlerAdd :: (Integral a, Integral b) => a -> b -> Word16 -adlerAdd x y = fromIntegral ((x32 + y32) `mod` 65521) - where - x32, y32 :: Word32 - x32 = fromIntegral x - y32 = fromIntegral y - -advanceAdler :: AdlerState -> Word8 -> AdlerState -advanceAdler state b = AdlerState a' b' - where - a' = adlerAdd (adlerA state) b - b' = adlerAdd (adlerB state) a' - -finalizeAdler :: AdlerState -> Word32 -finalizeAdler state = ((fromIntegral (adlerB state)) `shiftL` 16) - .|. fromIntegral (adlerA state) - - +module Codec.Compression.Zlib.Adler32( + AdlerState + , initialAdlerState + , advanceAdler + , finalizeAdler + ) + where + +import Data.Bits(shiftL, (.|.)) +import Data.Word(Word8, Word16, Word32) + +data AdlerState = AdlerState { adlerA :: !Word16, adlerB :: !Word16 } + +initialAdlerState :: AdlerState +initialAdlerState = AdlerState 1 0 + +adlerAdd :: (Integral a, Integral b) => a -> b -> Word16 +adlerAdd x y = fromIntegral ((x32 + y32) `mod` 65521) + where + x32, y32 :: Word32 + x32 = fromIntegral x + y32 = fromIntegral y + +advanceAdler :: AdlerState -> Word8 -> AdlerState +advanceAdler state b = AdlerState a' b' + where + a' = adlerAdd (adlerA state) b + b' = adlerAdd (adlerB state) a' + +finalizeAdler :: AdlerState -> Word32 +finalizeAdler state = ((fromIntegral (adlerB state)) `shiftL` 16) + .|. fromIntegral (adlerA state) + + diff --git a/src/Codec/Compression/Zlib/Deflate.hs b/src/Codec/Compression/Zlib/Deflate.hs --- a/src/Codec/Compression/Zlib/Deflate.hs +++ b/src/Codec/Compression/Zlib/Deflate.hs @@ -1,254 +1,256 @@ -{-# LANGUAGE MultiWayIf #-} -module Codec.Compression.Zlib.Deflate( - inflate - , computeCodeValues - ) - where - -import Codec.Compression.Zlib.HuffmanTree(HuffmanTree, - createHuffmanTree) -import Codec.Compression.Zlib.Monad(DeflateM, DecompressionError(..), - raise,nextBits,nextCode, - nextBlock,nextWord16,nextWord32, - emitByte,emitBlock,emitPastChunk, - advanceToByte, moveWindow, - finalAdler, finalize) -import Control.Monad(unless, replicateM) -import Data.Array(Array, array, (!)) -import Data.Bits(shiftL, complement) -import Data.Int(Int64) -import Data.List(sortBy) -import Data.IntMap.Strict(IntMap) -import qualified Data.IntMap.Strict as Map -import Data.Word(Word8) -import Numeric(showHex) - -inflate :: DeflateM () -inflate = - do fixedLit <- buildFixedLitTree - fixedDist <- buildFixedDistanceTree - go fixedLit fixedDist - where - go fixedLit fixedDist = - do isFinal <- inflateBlock fixedLit fixedDist - moveWindow - if isFinal - then checkChecksum >> finalize - else go fixedLit fixedDist - -- - checkChecksum = - do advanceToByte - ourAdler <- finalAdler - theirAdler <- nextWord32 - unless (theirAdler == ourAdler) $ - raise (ChecksumError ("checksum mismatch: " ++ showHex theirAdler "" ++ - " != " ++ showHex ourAdler "")) - -inflateBlock :: HuffmanTree Int -> HuffmanTree Int -> DeflateM Bool -inflateBlock fixedLitTree fixedDistanceTree = - do bfinal <- (== (1::Word8)) `fmap` nextBits 1 - btype <- nextBits 2 - case btype :: Word8 of - 0 -> -- no compression - do advanceToByte - len <- nextWord16 - nlen <- nextWord16 - unless (len == complement nlen) $ - raise (FormatError "Len/nlen mismatch in uncompressed block.") - emitBlock =<< nextBlock len - return bfinal - 1 -> -- compressed with fixed Huffman codes - do runInflate fixedLitTree fixedDistanceTree - return bfinal - 2 -> -- compressed with dynamic Huffman codes - do hlit <- (257+) `fmap` nextBits 5 - hdist <- (1+) `fmap` nextBits 5 - hclen <- (4+) `fmap` nextBits 4 - codeLens <- replicateM hclen (nextBits 3) - let codeLens' = zip codeLengthOrder codeLens - codeTree <- computeHuffmanTree codeLens' - lens <- getCodeLengths codeTree 0 (hlit + hdist) 0 Map.empty - -- We do this as a big chunk and then split it up because the spec - -- allows repeat codes to cross the hlit / hdist boundary. So now we - -- need to pull off the hdist items. - let (litlens, offdistlens) = - Map.partitionWithKey (\ k _ -> k < hlit) lens - distlens = Map.mapKeys (\ k -> k - hlit) offdistlens - litTree <- computeHuffmanTree (Map.toList litlens) - distTree <- computeHuffmanTree (Map.toList distlens) - runInflate litTree distTree - return bfinal - _ -> -- reserved / error - raise (FormatError ("Unacceptable BTYPE: " ++ show btype)) - where - runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM () - runInflate litTree distTree = - do code <- nextCode litTree - case compare code 256 of - LT -> do emitByte (fromIntegral code) - runInflate litTree distTree - EQ -> return () - GT -> do len <- getLength code - distCode <- nextCode distTree - dist <- getDistance distCode - emitPastChunk dist len - runInflate litTree distTree - --- ----------------------------------------------------------------------------- - -getCodeLengths :: HuffmanTree Int -> - Int -> Int -> Int -> - IntMap Int -> - DeflateM (IntMap Int) -getCodeLengths tree n maxl prev acc - | n >= maxl = return acc - | otherwise = - do code <- nextCode tree - if | code <= 15 -> - getCodeLengths tree (n+1) maxl code (Map.insert n code acc) - | code == 16 -> -- copy the previous code length 3 - 6 times - do num <- (3+) `fmap` nextBits 2 - getCodeLengths tree (n+num) maxl prev (addNTimes n num prev acc) - | code == 17 -> -- repeat a code length of 0 for 3 - 10 times - do num <- (3+) `fmap` nextBits 3 - getCodeLengths tree (n+num) maxl 0 (addNTimes n num 0 acc) - | code == 18 -> -- repeat a code length of 0 for 11 - 138 times - do num <- (11+) `fmap` nextBits 7 - getCodeLengths tree (n+num) maxl 0 (addNTimes n num 0 acc) - where - addNTimes idx count val old = - let idxs = take count [idx..] - vals = replicate count val - in Map.union old (Map.fromList (zip idxs vals)) - --- ----------------------------------------------------------------------------- - -getLength :: Int -> DeflateM Int64 -getLength c = lengthArray ! c -{-# INLINE getLength #-} - -lengthArray :: Array Int (DeflateM Int64) -lengthArray = array (257,285) [ - (257, return 3) - , (258, return 4) - , (259, return 5) - , (260, return 6) - , (261, return 7) - , (262, return 8) - , (263, return 9) - , (264, return 10) - , (265, (+ 11) `fmap` nextBits 1) - , (266, (+ 13) `fmap` nextBits 1) - , (267, (+ 15) `fmap` nextBits 1) - , (268, (+ 17) `fmap` nextBits 1) - , (269, (+ 19) `fmap` nextBits 2) - , (270, (+ 23) `fmap` nextBits 2) - , (271, (+ 27) `fmap` nextBits 2) - , (272, (+ 31) `fmap` nextBits 2) - , (273, (+ 35) `fmap` nextBits 3) - , (274, (+ 43) `fmap` nextBits 3) - , (275, (+ 51) `fmap` nextBits 3) - , (276, (+ 59) `fmap` nextBits 3) - , (277, (+ 67) `fmap` nextBits 4) - , (278, (+ 83) `fmap` nextBits 4) - , (279, (+ 99) `fmap` nextBits 4) - , (280, (+ 115) `fmap` nextBits 4) - , (281, (+ 131) `fmap` nextBits 5) - , (282, (+ 163) `fmap` nextBits 5) - , (283, (+ 195) `fmap` nextBits 5) - , (284, (+ 227) `fmap` nextBits 5) - , (285, return 258) - ] - -getDistance :: Int -> DeflateM Int -getDistance c = distanceArray ! c -{-# INLINE getDistance #-} - -distanceArray :: Array Int (DeflateM Int) -distanceArray = array (0,29) [ - (0, return 1) - , (1, return 2) - , (2, return 3) - , (3, return 4) - , (4, (+ 5) `fmap` nextBits 1) - , (5, (+ 7) `fmap` nextBits 1) - , (6, (+ 9) `fmap` nextBits 2) - , (7, (+ 13) `fmap` nextBits 2) - , (8, (+ 17) `fmap` nextBits 3) - , (9, (+ 25) `fmap` nextBits 3) - , (10, (+ 33) `fmap` nextBits 4) - , (11, (+ 49) `fmap` nextBits 4) - , (12, (+ 65) `fmap` nextBits 5) - , (13, (+ 97) `fmap` nextBits 5) - , (14, (+ 129) `fmap` nextBits 6) - , (15, (+ 193) `fmap` nextBits 6) - , (16, (+ 257) `fmap` nextBits 7) - , (17, (+ 385) `fmap` nextBits 7) - , (18, (+ 513) `fmap` nextBits 8) - , (19, (+ 769) `fmap` nextBits 8) - , (20, (+ 1025) `fmap` nextBits 9) - , (21, (+ 1537) `fmap` nextBits 9) - , (22, (+ 2049) `fmap` nextBits 10) - , (23, (+ 3073) `fmap` nextBits 10) - , (24, (+ 4097) `fmap` nextBits 11) - , (25, (+ 6145) `fmap` nextBits 11) - , (26, (+ 8193) `fmap` nextBits 12) - , (27, (+ 12289) `fmap` nextBits 12) - , (28, (+ 16385) `fmap` nextBits 13) - , (29, (+ 24577) `fmap` nextBits 13) - ] - --- ----------------------------------------------------------------------------- - -buildFixedLitTree :: DeflateM (HuffmanTree Int) -buildFixedLitTree = computeHuffmanTree - ([(x, 8) | x <- [0 .. 143]] ++ - [(x, 9) | x <- [144 .. 255]] ++ - [(x, 7) | x <- [256 .. 279]] ++ - [(x, 8) | x <- [280 .. 287]]) - -buildFixedDistanceTree :: DeflateM (HuffmanTree Int) -buildFixedDistanceTree = computeHuffmanTree [(x,5) | x <- [0..31]] - --- ----------------------------------------------------------------------------- - -computeHuffmanTree :: [(Int, Int)] -> DeflateM (HuffmanTree Int) -computeHuffmanTree initialData = - case createHuffmanTree (computeCodeValues initialData) of - Left err -> raise (HuffmanTreeError err) - Right x -> return x - -computeCodeValues :: [(Int, Int)] -> [(Int, Int, Int)] -computeCodeValues vals = Map.foldrWithKey (\ v (l, c) a -> (v,l,c):a) [] codes - where - valsNo0s = filter (\ (_, b) -> (b /= 0)) vals - valsSort = sortBy (\ (a,_) (b,_) -> compare a b) valsNo0s - blCount = foldr (\ (_,k) m -> Map.insertWith (+) k 1 m) Map.empty valsNo0s - nextcode = step2 0 1 (Map.insert 0 0 Map.empty) - lenTree = Map.fromList valsSort - codeTree = step3 (map fst valsSort) nextcode Map.empty - maxBits = maximum (map snd valsSort) - codes = Map.intersectionWith (,) lenTree codeTree - -- - step2 code bits nc - | bits > maxBits = nc - | otherwise = - let prevCount = Map.findWithDefault 0 (bits - 1) blCount - code' = (code + prevCount) `shiftL` 1 - in step2 code' (bits + 1) (Map.insert bits code' nc) - -- - step3 [] _ ct = ct - step3 (n:rest) nc ct = - let len = Map.findWithDefault 0 n lenTree - Just ncLen = Map.lookup len nc - ct' = Map.insert n ncLen ct - nc' = Map.insert len (ncLen + 1) nc - in if len == 0 - then step3 rest nc ct - else step3 rest nc' ct' - -codeLengthOrder :: [Int] -codeLengthOrder = - [16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15] - - +{-# LANGUAGE MultiWayIf #-} +module Codec.Compression.Zlib.Deflate( + inflate + , computeCodeValues + ) + where + +import Codec.Compression.Zlib.HuffmanTree(HuffmanTree, + createHuffmanTree) +import Codec.Compression.Zlib.Monad(DeflateM, DecompressionError(..), + raise,nextBits,nextCode, + nextBlock,nextWord16,nextWord32, + emitByte,emitBlock,emitPastChunk, + advanceToByte, moveWindow, + finalAdler, finalize) +import Control.Monad(unless, replicateM) +import Data.Array(Array, array, (!)) +import Data.Bits(shiftL, complement) +import Data.Int(Int64) +import Data.List(sortBy) +import Data.IntMap.Strict(IntMap) +import qualified Data.IntMap.Strict as Map +import Data.Word(Word8) +import Numeric(showHex) + +inflate :: DeflateM () +inflate = + do fixedLit <- buildFixedLitTree + fixedDist <- buildFixedDistanceTree + go fixedLit fixedDist + where + go fixedLit fixedDist = + do isFinal <- inflateBlock fixedLit fixedDist + moveWindow + if isFinal + then checkChecksum >> finalize + else go fixedLit fixedDist + -- + checkChecksum = + do advanceToByte + ourAdler <- finalAdler + theirAdler <- nextWord32 + unless (theirAdler == ourAdler) $ + raise (ChecksumError ("checksum mismatch: " ++ showHex theirAdler "" ++ + " != " ++ showHex ourAdler "")) + +inflateBlock :: HuffmanTree Int -> HuffmanTree Int -> DeflateM Bool +inflateBlock fixedLitTree fixedDistanceTree = + do bfinal <- (== (1::Word8)) `fmap` nextBits 1 + btype <- nextBits 2 + case btype :: Word8 of + 0 -> -- no compression + do advanceToByte + len <- nextWord16 + nlen <- nextWord16 + unless (len == complement nlen) $ + raise (FormatError "Len/nlen mismatch in uncompressed block.") + emitBlock =<< nextBlock len + return bfinal + 1 -> -- compressed with fixed Huffman codes + do runInflate fixedLitTree fixedDistanceTree + return bfinal + 2 -> -- compressed with dynamic Huffman codes + do hlit <- (257+) `fmap` nextBits 5 + hdist <- (1+) `fmap` nextBits 5 + hclen <- (4+) `fmap` nextBits 4 + codeLens <- replicateM hclen (nextBits 3) + let codeLens' = zip codeLengthOrder codeLens + codeTree <- computeHuffmanTree codeLens' + lens <- getCodeLengths codeTree 0 (hlit + hdist) 0 Map.empty + -- We do this as a big chunk and then split it up because the spec + -- allows repeat codes to cross the hlit / hdist boundary. So now we + -- need to pull off the hdist items. + let (litlens, offdistlens) = + Map.partitionWithKey (\ k _ -> k < hlit) lens + distlens = Map.mapKeys (\ k -> k - hlit) offdistlens + litTree <- computeHuffmanTree (Map.toList litlens) + distTree <- computeHuffmanTree (Map.toList distlens) + runInflate litTree distTree + return bfinal + _ -> -- reserved / error + raise (FormatError ("Unacceptable BTYPE: " ++ show btype)) + where + runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM () + runInflate litTree distTree = + do code <- nextCode litTree + case compare code 256 of + LT -> do emitByte (fromIntegral code) + runInflate litTree distTree + EQ -> return () + GT -> do len <- getLength code + distCode <- nextCode distTree + dist <- getDistance distCode + emitPastChunk dist len + runInflate litTree distTree + +-- ----------------------------------------------------------------------------- + +getCodeLengths :: HuffmanTree Int -> + Int -> Int -> Int -> + IntMap Int -> + DeflateM (IntMap Int) +getCodeLengths tree n maxl prev acc + | n >= maxl = return acc + | otherwise = + do code <- nextCode tree + if | code <= 15 -> + getCodeLengths tree (n+1) maxl code (Map.insert n code acc) + | code == 16 -> -- copy the previous code length 3 - 6 times + do num <- (3+) `fmap` nextBits 2 + getCodeLengths tree (n+num) maxl prev (addNTimes n num prev acc) + | code == 17 -> -- repeat a code length of 0 for 3 - 10 times + do num <- (3+) `fmap` nextBits 3 + getCodeLengths tree (n+num) maxl 0 (addNTimes n num 0 acc) + | code == 18 -> -- repeat a code length of 0 for 11 - 138 times + do num <- (11+) `fmap` nextBits 7 + getCodeLengths tree (n+num) maxl 0 (addNTimes n num 0 acc) + | otherwise -> + raise (DecompressionError ("Unexpected code: " ++ show code)) + where + addNTimes idx count val old = + let idxs = take count [idx..] + vals = replicate count val + in Map.union old (Map.fromList (zip idxs vals)) + +-- ----------------------------------------------------------------------------- + +getLength :: Int -> DeflateM Int64 +getLength c = lengthArray ! c +{-# INLINE getLength #-} + +lengthArray :: Array Int (DeflateM Int64) +lengthArray = array (257,285) [ + (257, return 3) + , (258, return 4) + , (259, return 5) + , (260, return 6) + , (261, return 7) + , (262, return 8) + , (263, return 9) + , (264, return 10) + , (265, (+ 11) `fmap` nextBits 1) + , (266, (+ 13) `fmap` nextBits 1) + , (267, (+ 15) `fmap` nextBits 1) + , (268, (+ 17) `fmap` nextBits 1) + , (269, (+ 19) `fmap` nextBits 2) + , (270, (+ 23) `fmap` nextBits 2) + , (271, (+ 27) `fmap` nextBits 2) + , (272, (+ 31) `fmap` nextBits 2) + , (273, (+ 35) `fmap` nextBits 3) + , (274, (+ 43) `fmap` nextBits 3) + , (275, (+ 51) `fmap` nextBits 3) + , (276, (+ 59) `fmap` nextBits 3) + , (277, (+ 67) `fmap` nextBits 4) + , (278, (+ 83) `fmap` nextBits 4) + , (279, (+ 99) `fmap` nextBits 4) + , (280, (+ 115) `fmap` nextBits 4) + , (281, (+ 131) `fmap` nextBits 5) + , (282, (+ 163) `fmap` nextBits 5) + , (283, (+ 195) `fmap` nextBits 5) + , (284, (+ 227) `fmap` nextBits 5) + , (285, return 258) + ] + +getDistance :: Int -> DeflateM Int +getDistance c = distanceArray ! c +{-# INLINE getDistance #-} + +distanceArray :: Array Int (DeflateM Int) +distanceArray = array (0,29) [ + (0, return 1) + , (1, return 2) + , (2, return 3) + , (3, return 4) + , (4, (+ 5) `fmap` nextBits 1) + , (5, (+ 7) `fmap` nextBits 1) + , (6, (+ 9) `fmap` nextBits 2) + , (7, (+ 13) `fmap` nextBits 2) + , (8, (+ 17) `fmap` nextBits 3) + , (9, (+ 25) `fmap` nextBits 3) + , (10, (+ 33) `fmap` nextBits 4) + , (11, (+ 49) `fmap` nextBits 4) + , (12, (+ 65) `fmap` nextBits 5) + , (13, (+ 97) `fmap` nextBits 5) + , (14, (+ 129) `fmap` nextBits 6) + , (15, (+ 193) `fmap` nextBits 6) + , (16, (+ 257) `fmap` nextBits 7) + , (17, (+ 385) `fmap` nextBits 7) + , (18, (+ 513) `fmap` nextBits 8) + , (19, (+ 769) `fmap` nextBits 8) + , (20, (+ 1025) `fmap` nextBits 9) + , (21, (+ 1537) `fmap` nextBits 9) + , (22, (+ 2049) `fmap` nextBits 10) + , (23, (+ 3073) `fmap` nextBits 10) + , (24, (+ 4097) `fmap` nextBits 11) + , (25, (+ 6145) `fmap` nextBits 11) + , (26, (+ 8193) `fmap` nextBits 12) + , (27, (+ 12289) `fmap` nextBits 12) + , (28, (+ 16385) `fmap` nextBits 13) + , (29, (+ 24577) `fmap` nextBits 13) + ] + +-- ----------------------------------------------------------------------------- + +buildFixedLitTree :: DeflateM (HuffmanTree Int) +buildFixedLitTree = computeHuffmanTree + ([(x, 8) | x <- [0 .. 143]] ++ + [(x, 9) | x <- [144 .. 255]] ++ + [(x, 7) | x <- [256 .. 279]] ++ + [(x, 8) | x <- [280 .. 287]]) + +buildFixedDistanceTree :: DeflateM (HuffmanTree Int) +buildFixedDistanceTree = computeHuffmanTree [(x,5) | x <- [0..31]] + +-- ----------------------------------------------------------------------------- + +computeHuffmanTree :: [(Int, Int)] -> DeflateM (HuffmanTree Int) +computeHuffmanTree initialData = + case createHuffmanTree (computeCodeValues initialData) of + Left err -> raise (HuffmanTreeError err) + Right x -> return x + +computeCodeValues :: [(Int, Int)] -> [(Int, Int, Int)] +computeCodeValues vals = Map.foldrWithKey (\ v (l, c) a -> (v,l,c):a) [] codes + where + valsNo0s = filter (\ (_, b) -> (b /= 0)) vals + valsSort = sortBy (\ (a,_) (b,_) -> compare a b) valsNo0s + blCount = foldr (\ (_,k) m -> Map.insertWith (+) k 1 m) Map.empty valsNo0s + nextcode = step2 0 1 (Map.insert 0 0 Map.empty) + lenTree = Map.fromList valsSort + codeTree = step3 (map fst valsSort) nextcode Map.empty + maxBits = maximum (map snd valsSort) + codes = Map.intersectionWith (,) lenTree codeTree + -- + step2 code bits nc + | bits > maxBits = nc + | otherwise = + let prevCount = Map.findWithDefault 0 (bits - 1) blCount + code' = (code + prevCount) `shiftL` 1 + in step2 code' (bits + 1) (Map.insert bits code' nc) + -- + step3 [] _ ct = ct + step3 (n:rest) nc ct = + let len = Map.findWithDefault 0 n lenTree + Just ncLen = Map.lookup len nc + ct' = Map.insert n ncLen ct + nc' = Map.insert len (ncLen + 1) nc + in if len == 0 + then step3 rest nc ct + else step3 rest nc' ct' + +codeLengthOrder :: [Int] +codeLengthOrder = + [16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15] + + diff --git a/src/Codec/Compression/Zlib/HuffmanTree.hs b/src/Codec/Compression/Zlib/HuffmanTree.hs --- a/src/Codec/Compression/Zlib/HuffmanTree.hs +++ b/src/Codec/Compression/Zlib/HuffmanTree.hs @@ -1,73 +1,73 @@ -module Codec.Compression.Zlib.HuffmanTree( - HuffmanTree - , AdvanceResult(..) - , createHuffmanTree - , advanceTree - ) - where - -import Data.Bits(testBit) -import Data.Word(Word8) - -data HuffmanTree a = HuffmanNode (HuffmanTree a) (HuffmanTree a) - | HuffmanValue a - | HuffmanEmpty - deriving (Show) - -data AdvanceResult a = AdvanceError String - | NewTree (HuffmanTree a) - | Result a - -emptyHuffmanTree :: HuffmanTree a -emptyHuffmanTree = HuffmanEmpty - -createHuffmanTree :: Show a => - [(a, Int, Int)] -> - Either String (HuffmanTree a) -createHuffmanTree = foldr addHuffmanNode' (Right emptyHuffmanTree) - where addHuffmanNode' (a, b, c) acc = - case acc of - Left err -> Left err - Right tree -> addHuffmanNode a b c tree - -addHuffmanNode :: Show a => - a -> Int -> Int -> HuffmanTree a -> - Either String (HuffmanTree a) -addHuffmanNode val len code node = - case node of - HuffmanEmpty | len == 0 -> - Right (HuffmanValue val) - HuffmanEmpty -> - case addHuffmanNode val (len - 1) code HuffmanEmpty of - Left err -> Left err - Right newNode - | testBit code (len - 1) -> Right (HuffmanNode HuffmanEmpty newNode) - | otherwise -> Right (HuffmanNode newNode HuffmanEmpty) - -- - HuffmanValue _ | len == 0 -> - Left "Two values point to the same place!" - HuffmanValue _ -> - Left "HuffmanValue hit while inserting a value!" - -- - HuffmanNode _ _ | len == 0 -> - Left ("Tried to add where the leaf is a node: " ++ show val) - HuffmanNode l r | testBit code (len - 1) -> - case addHuffmanNode val (len - 1) code r of - Left err -> Left err - Right r' -> Right (HuffmanNode l r') - HuffmanNode l r -> - case addHuffmanNode val (len - 1) code l of - Left err -> Left err - Right l' -> Right (HuffmanNode l' r) - -advanceTree :: Word8 -> HuffmanTree a -> AdvanceResult a -advanceTree x node = - case node of - HuffmanEmpty -> AdvanceError "Tried to advance empty tree!" - HuffmanValue _ -> AdvanceError "Tried to advance value!" - HuffmanNode l r -> - case if (x == 1) then r else l of - HuffmanEmpty -> AdvanceError "Advanced to empty tree!" - HuffmanValue y -> Result y - t -> NewTree t -{-# INLINE advanceTree #-} +module Codec.Compression.Zlib.HuffmanTree( + HuffmanTree + , AdvanceResult(..) + , createHuffmanTree + , advanceTree + ) + where + +import Data.Bits(testBit) +import Data.Word(Word8) + +data HuffmanTree a = HuffmanNode (HuffmanTree a) (HuffmanTree a) + | HuffmanValue a + | HuffmanEmpty + deriving (Show) + +data AdvanceResult a = AdvanceError String + | NewTree (HuffmanTree a) + | Result a + +emptyHuffmanTree :: HuffmanTree a +emptyHuffmanTree = HuffmanEmpty + +createHuffmanTree :: Show a => + [(a, Int, Int)] -> + Either String (HuffmanTree a) +createHuffmanTree = foldr addHuffmanNode' (Right emptyHuffmanTree) + where addHuffmanNode' (a, b, c) acc = + case acc of + Left err -> Left err + Right tree -> addHuffmanNode a b c tree + +addHuffmanNode :: Show a => + a -> Int -> Int -> HuffmanTree a -> + Either String (HuffmanTree a) +addHuffmanNode val len code node = + case node of + HuffmanEmpty | len == 0 -> + Right (HuffmanValue val) + HuffmanEmpty -> + case addHuffmanNode val (len - 1) code HuffmanEmpty of + Left err -> Left err + Right newNode + | testBit code (len - 1) -> Right (HuffmanNode HuffmanEmpty newNode) + | otherwise -> Right (HuffmanNode newNode HuffmanEmpty) + -- + HuffmanValue _ | len == 0 -> + Left "Two values point to the same place!" + HuffmanValue _ -> + Left "HuffmanValue hit while inserting a value!" + -- + HuffmanNode _ _ | len == 0 -> + Left ("Tried to add where the leaf is a node: " ++ show val) + HuffmanNode l r | testBit code (len - 1) -> + case addHuffmanNode val (len - 1) code r of + Left err -> Left err + Right r' -> Right (HuffmanNode l r') + HuffmanNode l r -> + case addHuffmanNode val (len - 1) code l of + Left err -> Left err + Right l' -> Right (HuffmanNode l' r) + +advanceTree :: Word8 -> HuffmanTree a -> AdvanceResult a +advanceTree x node = + case node of + HuffmanEmpty -> AdvanceError "Tried to advance empty tree!" + HuffmanValue _ -> AdvanceError "Tried to advance value!" + HuffmanNode l r -> + case if (x == 1) then r else l of + HuffmanEmpty -> AdvanceError "Advanced to empty tree!" + HuffmanValue y -> Result y + t -> NewTree t +{-# INLINE advanceTree #-} diff --git a/src/Codec/Compression/Zlib/Monad.hs b/src/Codec/Compression/Zlib/Monad.hs --- a/src/Codec/Compression/Zlib/Monad.hs +++ b/src/Codec/Compression/Zlib/Monad.hs @@ -1,306 +1,306 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE Rank2Types #-} -module Codec.Compression.Zlib.Monad( - DeflateM - , runDeflateM - , ZlibDecoder(..) - , raise - , DecompressionError(..) - -- * Getting data from the input stream. - , nextBits - , nextByte - , nextWord16 - , nextWord32 - , nextBlock - , nextCode - -- * Aligning - , advanceToByte - -- * Emitting data into the output window - , emitByte - , emitBlock - , emitPastChunk - -- * Getting and publishing output - , finalAdler - , moveWindow - , finalize - ) - where - -import Codec.Compression.Zlib.Adler32(AdlerState, initialAdlerState, - advanceAdler, finalizeAdler) -import Codec.Compression.Zlib.HuffmanTree(HuffmanTree, advanceTree, - AdvanceResult(..)) -import Codec.Compression.Zlib.OutputWindow(OutputWindow, emptyWindow, - emitExcess, addByte, - addChunk, addOldChunk, - finalizeWindow) -import Control.Exception(Exception) -import Control.Monad(Monad) -import Data.Bits(Bits(..)) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Int(Int64) -import Data.Typeable(Typeable) -import Data.Word(Word32, Word16, Word8) -import Prelude() -import Prelude.Compat - -data DecompressionState = DecompressionState { - dcsNextBitNo :: !Int - , dcsCurByte :: !Word8 - , dcsAdler32 :: !AdlerState - , dcsInput :: !S.ByteString - , dcsOutput :: !OutputWindow - } - -instance Show DecompressionState where - show dcs = "DecompressionState" - --- ----------------------------------------------------------------------------- - -data DecompressionError = HuffmanTreeError String - | FormatError String - | DecompressionError String - | HeaderError String - | ChecksumError String - deriving (Typeable, Eq) - -instance Show DecompressionError where - show x = - case x of - HuffmanTreeError s -> "Huffman tree manipulation error: " ++ s - FormatError s -> "Block format error: " ++ s - DecompressionError s -> "Decompression error: " ++ s - HeaderError s -> "Header error: " ++ s - ChecksumError s -> "Checksum error: " ++ s - -instance Exception DecompressionError - --- ----------------------------------------------------------------------------- - -newtype DeflateM a = DeflateM { - unDeflateM :: DecompressionState -> - (DecompressionState -> a -> ZlibDecoder) -> - ZlibDecoder - } - -instance Applicative DeflateM where - pure x = DeflateM (\ s k -> k s x) - - f <*> x = DeflateM $ \ s1 k -> - unDeflateM f s1 $ \ s2 g -> - unDeflateM x s2 $ \ s3 y -> k s3 (g y) - - m *> n = DeflateM $ \ s1 k -> - unDeflateM m s1 $ \ s2 _ -> unDeflateM n s2 k - - {-# INLINE pure #-} - {-# INLINE (<*>) #-} - {-# INLINE (*>) #-} - - -instance Functor DeflateM where - fmap f m = DeflateM (\s k -> unDeflateM m s (\s' a -> k s' (f a))) - {-# INLINE fmap #-} - -instance Monad DeflateM where - {-# INLINE return #-} - return = pure - - {-# INLINE (>>=) #-} - m >>= f = DeflateM $ \ s1 k -> - unDeflateM m s1 $ \ s2 a -> unDeflateM (f a) s2 k - - (>>) = (*>) - {-# INLINE (>>) #-} - -get :: DeflateM DecompressionState -get = DeflateM (\ s k -> k s s) -{-# INLINE get #-} - -set :: DecompressionState -> DeflateM () -set !s = DeflateM (\ _ k -> k s ()) -{-# INLINE set #-} - -raise :: DecompressionError -> DeflateM a -raise e = DeflateM (\ _ _ -> DecompError e) -{-# INLINE raise #-} - -initialState :: DecompressionState -initialState = DecompressionState { - dcsNextBitNo = 8 - , dcsCurByte = 0 - , dcsAdler32 = initialAdlerState - , dcsInput = S.empty - , dcsOutput = emptyWindow - } - --- ----------------------------------------------------------------------------- - -data ZlibDecoder = NeedMore (S.ByteString -> ZlibDecoder) - | Chunk L.ByteString ZlibDecoder - | Done - | DecompError DecompressionError - -runDeflateM :: DeflateM () -> ZlibDecoder -runDeflateM m = unDeflateM m initialState (\ _ _ -> Done) -{-# INLINE runDeflateM #-} - --- ----------------------------------------------------------------------------- - -getNextChunk :: DeflateM () -getNextChunk = DeflateM $ \ st k -> NeedMore (loadChunk st k) - where - loadChunk st k bstr = - case S.uncons bstr of - Nothing -> NeedMore (loadChunk st k) - Just (nextb, rest) -> - k st { dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest } () - -{-# SPECIALIZE nextBits :: Int -> DeflateM Word8 #-} -{-# SPECIALIZE nextBits :: Int -> DeflateM Int #-} -{-# SPECIALIZE nextBits :: Int -> DeflateM Int64 #-} -{-# INLINE nextBits #-} -nextBits :: (Num a, Bits a) => Int -> DeflateM a -nextBits x = nextBits' x 0 0 - -{-# SPECIALIZE nextBits' :: Int -> Int -> Word8 -> DeflateM Word8 #-} -{-# SPECIALIZE nextBits' :: Int -> Int -> Int -> DeflateM Int #-} -{-# SPECIALIZE nextBits' :: Int -> Int -> Int64 -> DeflateM Int64 #-} -{-# INLINE nextBits' #-} -nextBits' :: (Num a, Bits a) => Int -> Int -> a -> DeflateM a -nextBits' !x' !shiftNum !acc - | x' == 0 = return acc - | otherwise = - do dcs <- get - case dcsNextBitNo dcs of - 8 -> case S.uncons (dcsInput dcs) of - Nothing -> - do getNextChunk - nextBits' x' shiftNum acc - Just (nextb, rest) -> - do set dcs{dcsNextBitNo=0,dcsCurByte=nextb,dcsInput=rest} - nextBits' x' shiftNum acc - nextBitNo -> - do let !myBits = min x' (8 - nextBitNo) - !base = dcsCurByte dcs `shiftR` nextBitNo - !mask = complement (0xFF `shiftL` myBits) - !res = fromIntegral (base .&. mask) - !acc' = acc .|. (res `shiftL` shiftNum) - set dcs { dcsNextBitNo=nextBitNo + myBits } - nextBits' (x' - myBits) (shiftNum + myBits) acc' - -nextByte :: DeflateM Word8 -nextByte = - do dcs <- get - if | dcsNextBitNo dcs == 0 -> do set dcs{ dcsNextBitNo = 8 } - return (dcsCurByte dcs) - | dcsNextBitNo dcs /= 8 -> nextBits 8 -- we're not aligned. sigh. - | otherwise -> case S.uncons (dcsInput dcs) of - Nothing -> getNextChunk >> nextByte - Just (nextb, rest) -> - do set dcs{ dcsNextBitNo = 8, - dcsCurByte = nextb, - dcsInput = rest } - return nextb - -nextWord16 :: DeflateM Word16 -nextWord16 = - do low <- fromIntegral `fmap` nextByte - high <- fromIntegral `fmap` nextByte - return ((high `shiftL` 8) .|. low) - -nextWord32 :: DeflateM Word32 -nextWord32 = - do a <- fromIntegral `fmap` nextByte - b <- fromIntegral `fmap` nextByte - c <- fromIntegral `fmap` nextByte - d <- fromIntegral `fmap` nextByte - return ((a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d) - -nextBlock :: Integral a => a -> DeflateM L.ByteString -nextBlock amt = - do dcs <- get - if | dcsNextBitNo dcs == 0 -> - do let startByte = dcsCurByte dcs - set dcs{ dcsNextBitNo = 8 } - rest <- nextBlock (amt - 1) - return (L.cons startByte rest) - | dcsNextBitNo dcs == 8 -> - getBlock (fromIntegral amt) (dcsInput dcs) - | otherwise -> - fail "Can't get a block on a non-byte boundary." - where - getBlock len bstr - | len < S.length bstr = do let (mine, rest) = S.splitAt len bstr - dcs <- get - set dcs{ dcsNextBitNo = 8, dcsInput = rest } - return (L.fromStrict mine) - | S.null bstr = do getNextChunk - dcs <- get - let byte1 = dcsCurByte dcs - rest <- getBlock (len - 1) (dcsInput dcs) - return (L.cons byte1 rest) - | otherwise = do rest <- getBlock (len - S.length bstr) S.empty - return (L.fromStrict bstr `L.append` rest) - -nextCode :: Show a => HuffmanTree a -> DeflateM a -nextCode tree = - do b <- nextBits 1 - case advanceTree b tree of - AdvanceError str -> raise (HuffmanTreeError str) - NewTree tree' -> nextCode tree' - Result x -> return x -{-# INLINE nextCode #-} - -advanceToByte :: DeflateM () -advanceToByte = - do dcs <- get - set dcs{ dcsNextBitNo = 8 } - -emitByte :: Word8 -> DeflateM () -emitByte b = - do dcs <- get - set dcs{ dcsOutput = dcsOutput dcs `addByte` b - , dcsAdler32 = advanceAdler (dcsAdler32 dcs) b } -{-# INLINE emitByte #-} - -emitBlock :: L.ByteString -> DeflateM () -emitBlock b = - do dcs <- get - set dcs { dcsOutput = dcsOutput dcs `addChunk` b - , dcsAdler32 = L.foldl advanceAdler (dcsAdler32 dcs) b } - -emitPastChunk :: Int -> Int64 -> DeflateM () -emitPastChunk dist len = - do dcs <- get - let (output', newChunk) = addOldChunk (dcsOutput dcs) dist len - set dcs { dcsOutput = output' - , dcsAdler32 = L.foldl advanceAdler (dcsAdler32 dcs) newChunk } -{-# INLINE emitPastChunk #-} - -finalAdler :: DeflateM Word32 -finalAdler = (finalizeAdler . dcsAdler32) `fmap` get - -moveWindow :: DeflateM () -moveWindow = - do dcs <- get - case emitExcess (dcsOutput dcs) of - Nothing -> - return () - Just (builtChunks, output') -> - do set dcs{ dcsOutput = output' } - publishLazy builtChunks - -finalize :: DeflateM () -finalize = - do dcs <- get - publishLazy (finalizeWindow (dcsOutput dcs)) - -{-# INLINE publishLazy #-} -publishLazy :: L.ByteString -> DeflateM () -publishLazy lbstr = DeflateM (\ st k -> Chunk lbstr (k st ())) +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE Rank2Types #-} +module Codec.Compression.Zlib.Monad( + DeflateM + , runDeflateM + , ZlibDecoder(..) + , raise + , DecompressionError(..) + -- * Getting data from the input stream. + , nextBits + , nextByte + , nextWord16 + , nextWord32 + , nextBlock + , nextCode + -- * Aligning + , advanceToByte + -- * Emitting data into the output window + , emitByte + , emitBlock + , emitPastChunk + -- * Getting and publishing output + , finalAdler + , moveWindow + , finalize + ) + where + +import Codec.Compression.Zlib.Adler32(AdlerState, initialAdlerState, + advanceAdler, finalizeAdler) +import Codec.Compression.Zlib.HuffmanTree(HuffmanTree, advanceTree, + AdvanceResult(..)) +import Codec.Compression.Zlib.OutputWindow(OutputWindow, emptyWindow, + emitExcess, addByte, + addChunk, addOldChunk, + finalizeWindow) +import Control.Exception(Exception) +import Control.Monad(Monad) +import Data.Bits(Bits(..)) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int(Int64) +import Data.Typeable(Typeable) +import Data.Word(Word32, Word16, Word8) +import Prelude() +import Prelude.Compat + +data DecompressionState = DecompressionState { + dcsNextBitNo :: !Int + , dcsCurByte :: !Word8 + , dcsAdler32 :: !AdlerState + , dcsInput :: !S.ByteString + , dcsOutput :: !OutputWindow + } + +instance Show DecompressionState where + show dcs = "DecompressionState" + +-- ----------------------------------------------------------------------------- + +data DecompressionError = HuffmanTreeError String + | FormatError String + | DecompressionError String + | HeaderError String + | ChecksumError String + deriving (Typeable, Eq) + +instance Show DecompressionError where + show x = + case x of + HuffmanTreeError s -> "Huffman tree manipulation error: " ++ s + FormatError s -> "Block format error: " ++ s + DecompressionError s -> "Decompression error: " ++ s + HeaderError s -> "Header error: " ++ s + ChecksumError s -> "Checksum error: " ++ s + +instance Exception DecompressionError + +-- ----------------------------------------------------------------------------- + +newtype DeflateM a = DeflateM { + unDeflateM :: DecompressionState -> + (DecompressionState -> a -> ZlibDecoder) -> + ZlibDecoder + } + +instance Applicative DeflateM where + pure x = DeflateM (\ s k -> k s x) + + f <*> x = DeflateM $ \ s1 k -> + unDeflateM f s1 $ \ s2 g -> + unDeflateM x s2 $ \ s3 y -> k s3 (g y) + + m *> n = DeflateM $ \ s1 k -> + unDeflateM m s1 $ \ s2 _ -> unDeflateM n s2 k + + {-# INLINE pure #-} + {-# INLINE (<*>) #-} + {-# INLINE (*>) #-} + + +instance Functor DeflateM where + fmap f m = DeflateM (\s k -> unDeflateM m s (\s' a -> k s' (f a))) + {-# INLINE fmap #-} + +instance Monad DeflateM where + {-# INLINE return #-} + return = pure + + {-# INLINE (>>=) #-} + m >>= f = DeflateM $ \ s1 k -> + unDeflateM m s1 $ \ s2 a -> unDeflateM (f a) s2 k + + (>>) = (*>) + {-# INLINE (>>) #-} + +get :: DeflateM DecompressionState +get = DeflateM (\ s k -> k s s) +{-# INLINE get #-} + +set :: DecompressionState -> DeflateM () +set !s = DeflateM (\ _ k -> k s ()) +{-# INLINE set #-} + +raise :: DecompressionError -> DeflateM a +raise e = DeflateM (\ _ _ -> DecompError e) +{-# INLINE raise #-} + +initialState :: DecompressionState +initialState = DecompressionState { + dcsNextBitNo = 8 + , dcsCurByte = 0 + , dcsAdler32 = initialAdlerState + , dcsInput = S.empty + , dcsOutput = emptyWindow + } + +-- ----------------------------------------------------------------------------- + +data ZlibDecoder = NeedMore (S.ByteString -> ZlibDecoder) + | Chunk L.ByteString ZlibDecoder + | Done + | DecompError DecompressionError + +runDeflateM :: DeflateM () -> ZlibDecoder +runDeflateM m = unDeflateM m initialState (\ _ _ -> Done) +{-# INLINE runDeflateM #-} + +-- ----------------------------------------------------------------------------- + +getNextChunk :: DeflateM () +getNextChunk = DeflateM $ \ st k -> NeedMore (loadChunk st k) + where + loadChunk st k bstr = + case S.uncons bstr of + Nothing -> NeedMore (loadChunk st k) + Just (nextb, rest) -> + k st { dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest } () + +{-# SPECIALIZE nextBits :: Int -> DeflateM Word8 #-} +{-# SPECIALIZE nextBits :: Int -> DeflateM Int #-} +{-# SPECIALIZE nextBits :: Int -> DeflateM Int64 #-} +{-# INLINE nextBits #-} +nextBits :: (Num a, Bits a) => Int -> DeflateM a +nextBits x = nextBits' x 0 0 + +{-# SPECIALIZE nextBits' :: Int -> Int -> Word8 -> DeflateM Word8 #-} +{-# SPECIALIZE nextBits' :: Int -> Int -> Int -> DeflateM Int #-} +{-# SPECIALIZE nextBits' :: Int -> Int -> Int64 -> DeflateM Int64 #-} +{-# INLINE nextBits' #-} +nextBits' :: (Num a, Bits a) => Int -> Int -> a -> DeflateM a +nextBits' !x' !shiftNum !acc + | x' == 0 = return acc + | otherwise = + do dcs <- get + case dcsNextBitNo dcs of + 8 -> case S.uncons (dcsInput dcs) of + Nothing -> + do getNextChunk + nextBits' x' shiftNum acc + Just (nextb, rest) -> + do set dcs{dcsNextBitNo=0,dcsCurByte=nextb,dcsInput=rest} + nextBits' x' shiftNum acc + nextBitNo -> + do let !myBits = min x' (8 - nextBitNo) + !base = dcsCurByte dcs `shiftR` nextBitNo + !mask = complement (0xFF `shiftL` myBits) + !res = fromIntegral (base .&. mask) + !acc' = acc .|. (res `shiftL` shiftNum) + set dcs { dcsNextBitNo=nextBitNo + myBits } + nextBits' (x' - myBits) (shiftNum + myBits) acc' + +nextByte :: DeflateM Word8 +nextByte = + do dcs <- get + if | dcsNextBitNo dcs == 0 -> do set dcs{ dcsNextBitNo = 8 } + return (dcsCurByte dcs) + | dcsNextBitNo dcs /= 8 -> nextBits 8 -- we're not aligned. sigh. + | otherwise -> case S.uncons (dcsInput dcs) of + Nothing -> getNextChunk >> nextByte + Just (nextb, rest) -> + do set dcs{ dcsNextBitNo = 8, + dcsCurByte = nextb, + dcsInput = rest } + return nextb + +nextWord16 :: DeflateM Word16 +nextWord16 = + do low <- fromIntegral `fmap` nextByte + high <- fromIntegral `fmap` nextByte + return ((high `shiftL` 8) .|. low) + +nextWord32 :: DeflateM Word32 +nextWord32 = + do a <- fromIntegral `fmap` nextByte + b <- fromIntegral `fmap` nextByte + c <- fromIntegral `fmap` nextByte + d <- fromIntegral `fmap` nextByte + return ((a `shiftL` 24) .|. (b `shiftL` 16) .|. (c `shiftL` 8) .|. d) + +nextBlock :: Integral a => a -> DeflateM L.ByteString +nextBlock amt = + do dcs <- get + if | dcsNextBitNo dcs == 0 -> + do let startByte = dcsCurByte dcs + set dcs{ dcsNextBitNo = 8 } + rest <- nextBlock (amt - 1) + return (L.cons startByte rest) + | dcsNextBitNo dcs == 8 -> + getBlock (fromIntegral amt) (dcsInput dcs) + | otherwise -> + raise (FormatError "Can't get a block on a non-byte boundary.") + where + getBlock len bstr + | len < S.length bstr = do let (mine, rest) = S.splitAt len bstr + dcs <- get + set dcs{ dcsNextBitNo = 8, dcsInput = rest } + return (L.fromStrict mine) + | S.null bstr = do getNextChunk + dcs <- get + let byte1 = dcsCurByte dcs + rest <- getBlock (len - 1) (dcsInput dcs) + return (L.cons byte1 rest) + | otherwise = do rest <- getBlock (len - S.length bstr) S.empty + return (L.fromStrict bstr `L.append` rest) + +nextCode :: Show a => HuffmanTree a -> DeflateM a +nextCode tree = + do b <- nextBits 1 + case advanceTree b tree of + AdvanceError str -> raise (HuffmanTreeError str) + NewTree tree' -> nextCode tree' + Result x -> return x +{-# INLINE nextCode #-} + +advanceToByte :: DeflateM () +advanceToByte = + do dcs <- get + set dcs{ dcsNextBitNo = 8 } + +emitByte :: Word8 -> DeflateM () +emitByte b = + do dcs <- get + set dcs{ dcsOutput = dcsOutput dcs `addByte` b + , dcsAdler32 = advanceAdler (dcsAdler32 dcs) b } +{-# INLINE emitByte #-} + +emitBlock :: L.ByteString -> DeflateM () +emitBlock b = + do dcs <- get + set dcs { dcsOutput = dcsOutput dcs `addChunk` b + , dcsAdler32 = L.foldl advanceAdler (dcsAdler32 dcs) b } + +emitPastChunk :: Int -> Int64 -> DeflateM () +emitPastChunk dist len = + do dcs <- get + let (output', newChunk) = addOldChunk (dcsOutput dcs) dist len + set dcs { dcsOutput = output' + , dcsAdler32 = L.foldl advanceAdler (dcsAdler32 dcs) newChunk } +{-# INLINE emitPastChunk #-} + +finalAdler :: DeflateM Word32 +finalAdler = (finalizeAdler . dcsAdler32) `fmap` get + +moveWindow :: DeflateM () +moveWindow = + do dcs <- get + case emitExcess (dcsOutput dcs) of + Nothing -> + return () + Just (builtChunks, output') -> + do set dcs{ dcsOutput = output' } + publishLazy builtChunks + +finalize :: DeflateM () +finalize = + do dcs <- get + publishLazy (finalizeWindow (dcsOutput dcs)) + +{-# INLINE publishLazy #-} +publishLazy :: L.ByteString -> DeflateM () +publishLazy lbstr = DeflateM (\ st k -> Chunk lbstr (k st ())) diff --git a/src/Codec/Compression/Zlib/OutputWindow.hs b/src/Codec/Compression/Zlib/OutputWindow.hs --- a/src/Codec/Compression/Zlib/OutputWindow.hs +++ b/src/Codec/Compression/Zlib/OutputWindow.hs @@ -1,99 +1,99 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Codec.Compression.Zlib.OutputWindow( - OutputWindow - , emptyWindow - , emitExcess - , finalizeWindow - , addByte - , addChunk - , addOldChunk - ) - where - -import Data.ByteString.Builder(Builder, toLazyByteString, word8, - lazyByteString, byteString) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.FingerTree(FingerTree, Measured, ViewL(..), - empty, (|>), split, measure, viewl) -import Data.Foldable.Compat(foldMap) -import Data.Int(Int64) -import Data.Semigroup as Sem -import Data.Word(Word8) -import Prelude() -import Prelude.Compat - -type WindowType = FingerTree Int S.ByteString - -instance Sem.Semigroup Int where - (<>) = (+) - -instance Monoid Int where - mempty = 0 - {-# INLINE mempty #-} - mappend = (+) - {-# INLINE mappend #-} - -instance Measured Int S.ByteString where - measure = S.length - {-# INLINE measure #-} - -data OutputWindow = OutputWindow { - owWindow :: WindowType - , owRecent :: Builder - } - -emptyWindow :: OutputWindow -emptyWindow = OutputWindow empty mempty - -emitExcess :: OutputWindow -> Maybe (L.ByteString, OutputWindow) -emitExcess ow - | totalMeasure < 65536 = Nothing - | otherwise = Just (excess, ow{ owWindow = window' }) - where - window = owWindow ow - totalMeasure = measure window - excessAmount = totalMeasure - 32768 - (excessFT, window') = split (>= excessAmount) window - excess = toLazyByteString (foldMap byteString excessFT) - -finalizeWindow :: OutputWindow -> L.ByteString -finalizeWindow ow = - toLazyByteString (foldMap byteString (owWindow ow) <> owRecent ow) - --- ----------------------------------------------------------------------------- - -addByte :: OutputWindow -> Word8 -> OutputWindow -addByte ow b = ow{ owRecent = owRecent ow <> word8 b } - -addChunk :: OutputWindow -> L.ByteString -> OutputWindow -addChunk ow bs = ow{ owRecent = owRecent ow <> lazyByteString bs } - -addOldChunk :: OutputWindow -> Int -> Int64 -> (OutputWindow, L.ByteString) -addOldChunk ow dist len = (OutputWindow output (lazyByteString chunk), chunk) - where - output = L.foldlChunks (|>) (owWindow ow) (toLazyByteString (owRecent ow)) - dropAmt = measure output - dist - (prev, sme) = split (> dropAmt) output - s :< rest = viewl sme - start = S.take (fromIntegral len) (S.drop (dropAmt-measure prev) s) - len' = fromIntegral len - S.length start - chunkBase = getChunk rest len' (byteString start) - chunkInf = chunkBase `L.append` chunkInf - chunk = L.take len chunkInf - -getChunk :: WindowType -> Int -> Builder -> L.ByteString -getChunk win len acc - | len <= 0 = toLazyByteString acc - | otherwise = - case viewl win of - EmptyL -> toLazyByteString acc - cur :< rest -> - let curlen = S.length cur - in case compare (S.length cur) len of - LT -> getChunk rest (len - curlen) (acc <> byteString cur) - EQ -> toLazyByteString (acc <> byteString cur) - GT -> let (mine, _notMine) = S.splitAt len cur - in toLazyByteString (acc <> byteString mine) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Codec.Compression.Zlib.OutputWindow( + OutputWindow + , emptyWindow + , emitExcess + , finalizeWindow + , addByte + , addChunk + , addOldChunk + ) + where + +import Data.ByteString.Builder(Builder, toLazyByteString, word8, + lazyByteString, byteString) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.FingerTree(FingerTree, Measured, ViewL(..), + empty, (|>), split, measure, viewl) +import Data.Foldable.Compat(foldMap) +import Data.Int(Int64) +import Data.Semigroup as Sem +import Data.Word(Word8) +import Prelude() +import Prelude.Compat + +type WindowType = FingerTree Int S.ByteString + +instance Sem.Semigroup Int where + (<>) = (+) + +instance Monoid Int where + mempty = 0 + {-# INLINE mempty #-} + mappend = (+) + {-# INLINE mappend #-} + +instance Measured Int S.ByteString where + measure = S.length + {-# INLINE measure #-} + +data OutputWindow = OutputWindow { + owWindow :: WindowType + , owRecent :: Builder + } + +emptyWindow :: OutputWindow +emptyWindow = OutputWindow empty mempty + +emitExcess :: OutputWindow -> Maybe (L.ByteString, OutputWindow) +emitExcess ow + | totalMeasure < 65536 = Nothing + | otherwise = Just (excess, ow{ owWindow = window' }) + where + window = owWindow ow + totalMeasure = measure window + excessAmount = totalMeasure - 32768 + (excessFT, window') = split (>= excessAmount) window + excess = toLazyByteString (foldMap byteString excessFT) + +finalizeWindow :: OutputWindow -> L.ByteString +finalizeWindow ow = + toLazyByteString (foldMap byteString (owWindow ow) <> owRecent ow) + +-- ----------------------------------------------------------------------------- + +addByte :: OutputWindow -> Word8 -> OutputWindow +addByte ow b = ow{ owRecent = owRecent ow <> word8 b } + +addChunk :: OutputWindow -> L.ByteString -> OutputWindow +addChunk ow bs = ow{ owRecent = owRecent ow <> lazyByteString bs } + +addOldChunk :: OutputWindow -> Int -> Int64 -> (OutputWindow, L.ByteString) +addOldChunk ow dist len = (OutputWindow output (lazyByteString chunk), chunk) + where + output = L.foldlChunks (|>) (owWindow ow) (toLazyByteString (owRecent ow)) + dropAmt = measure output - dist + (prev, sme) = split (> dropAmt) output + s :< rest = viewl sme + start = S.take (fromIntegral len) (S.drop (dropAmt-measure prev) s) + len' = fromIntegral len - S.length start + chunkBase = getChunk rest len' (byteString start) + chunkInf = chunkBase `L.append` chunkInf + chunk = L.take len chunkInf + +getChunk :: WindowType -> Int -> Builder -> L.ByteString +getChunk win len acc + | len <= 0 = toLazyByteString acc + | otherwise = + case viewl win of + EmptyL -> toLazyByteString acc + cur :< rest -> + let curlen = S.length cur + in case compare (S.length cur) len of + LT -> getChunk rest (len - curlen) (acc <> byteString cur) + EQ -> toLazyByteString (acc <> byteString cur) + GT -> let (mine, _notMine) = S.splitAt len cur + in toLazyByteString (acc <> byteString mine) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,98 +1,98 @@ -import Codec.Compression.Zlib -import Codec.Compression.Zlib.Deflate -import Data.ByteString.Lazy(readFile) -import Data.Char (ord) -import Data.List(last, isPrefixOf) -import Prelude hiding (readFile) -import System.FilePath -import Test.Tasty -import Test.Tasty.HUnit - --- ----------------------------------------------------------------------------- - -rfcSimpleTestLengths :: [(Int, Int)] -rfcSimpleTestLengths = [ - (ord 'A', 3) - , (ord 'B', 3) - , (ord 'C', 3) - , (ord 'D', 3) - , (ord 'E', 3) - , (ord 'F', 2) - , (ord 'G', 4) - , (ord 'H', 4) - ] - -rfcSimpleTestResults :: [(Int, Int, Int)] -rfcSimpleTestResults = [ - (ord 'A', 3, 2) -- 010 - , (ord 'B', 3, 3) -- 011 - , (ord 'C', 3, 4) -- 100 - , (ord 'D', 3, 5) -- 101 - , (ord 'E', 3, 6) -- 110 - , (ord 'F', 2, 0) -- 00 - , (ord 'G', 4, 14) -- 1110 - , (ord 'H', 4, 15) -- 1111 - ] - -fixedHuffmanLengths :: [(Int, Int)] -fixedHuffmanLengths = - ([(x, 8) | x <- [0 .. 143]] ++ - [(x, 9) | x <- [144 .. 255]] ++ - [(x, 7) | x <- [256 .. 279]] ++ - [(x, 8) | x <- [280 .. 287]]) - -fixedHuffmanResults :: [(Int, Int, Int)] -fixedHuffmanResults = - ([(fst x, 8, snd x) | x <- zip [0 ..143] [48 ..191]] ++ -- 00110000 through 10111111 - [(fst x, 9, snd x) | x <- zip [144..255] [400..511]] ++ -- 110010000 through 111111111 - [(fst x, 7, snd x) | x <- zip [256..279] [0 .. 23]] ++ -- 0000000 through 0010111 - [(fst x, 8, snd x) | x <- zip [280..287] [192..199]]) -- 11000000 through 11000111 - --- ----------------------------------------------------------------------------- - -testCases :: [FilePath] -testCases = [ "randtest1", "randtest2", "randtest3", - "rfctest1", "rfctest2", "rfctest3", - "zerotest1", "zerotest2", "zerotest3" ] - -buildGoldTestCases :: IO TestTree -buildGoldTestCases = - do trees <- mapM buildGoldTest testCases - return (testGroup "Decompression Tests" trees) - -buildGoldTest :: FilePath -> IO TestTree -buildGoldTest test = - do let compressedFile = "test" "test-cases" test <.> "z" - goldFile = "test" "test-cases" test <.> "gold" - compressedBStr <- readFile compressedFile - goldBStr <- readFile goldFile - return (testCase (toTestCaseName test) - (assertEqual test (Right goldBStr) (decompress compressedBStr))) - -toTestCaseName :: FilePath -> String -toTestCaseName fpath = prefix ++ suffix - where - prefix | "zero" `isPrefixOf` fpath = "Zero test #" - | "rand" `isPrefixOf` fpath = "Random test #" - | "rfc" `isPrefixOf` fpath = "RFC test #" - | otherwise = error "Bad test case prefix." - suffix = [last fpath] - --- ----------------------------------------------------------------------------- - -zlibTests :: IO TestTree -zlibTests = - do decompTests <- buildGoldTestCases - return $ testGroup "DEFLATE / ZLib Algorithm Testing" [ - testCase "RFC 1951 Code Generation Test" - (assertEqual "" (computeCodeValues rfcSimpleTestLengths) - rfcSimpleTestResults) - , testCase "Fixed Huffman lengths make right tree" - (assertEqual "" (computeCodeValues fixedHuffmanLengths) - fixedHuffmanResults) - , decompTests - ] - -main :: IO () -main = defaultMain =<< zlibTests - +import Codec.Compression.Zlib +import Codec.Compression.Zlib.Deflate +import Data.ByteString.Lazy(readFile) +import Data.Char (ord) +import Data.List(last, isPrefixOf) +import Prelude hiding (readFile) +import System.FilePath +import Test.Tasty +import Test.Tasty.HUnit + +-- ----------------------------------------------------------------------------- + +rfcSimpleTestLengths :: [(Int, Int)] +rfcSimpleTestLengths = [ + (ord 'A', 3) + , (ord 'B', 3) + , (ord 'C', 3) + , (ord 'D', 3) + , (ord 'E', 3) + , (ord 'F', 2) + , (ord 'G', 4) + , (ord 'H', 4) + ] + +rfcSimpleTestResults :: [(Int, Int, Int)] +rfcSimpleTestResults = [ + (ord 'A', 3, 2) -- 010 + , (ord 'B', 3, 3) -- 011 + , (ord 'C', 3, 4) -- 100 + , (ord 'D', 3, 5) -- 101 + , (ord 'E', 3, 6) -- 110 + , (ord 'F', 2, 0) -- 00 + , (ord 'G', 4, 14) -- 1110 + , (ord 'H', 4, 15) -- 1111 + ] + +fixedHuffmanLengths :: [(Int, Int)] +fixedHuffmanLengths = + ([(x, 8) | x <- [0 .. 143]] ++ + [(x, 9) | x <- [144 .. 255]] ++ + [(x, 7) | x <- [256 .. 279]] ++ + [(x, 8) | x <- [280 .. 287]]) + +fixedHuffmanResults :: [(Int, Int, Int)] +fixedHuffmanResults = + ([(fst x, 8, snd x) | x <- zip [0 ..143] [48 ..191]] ++ -- 00110000 through 10111111 + [(fst x, 9, snd x) | x <- zip [144..255] [400..511]] ++ -- 110010000 through 111111111 + [(fst x, 7, snd x) | x <- zip [256..279] [0 .. 23]] ++ -- 0000000 through 0010111 + [(fst x, 8, snd x) | x <- zip [280..287] [192..199]]) -- 11000000 through 11000111 + +-- ----------------------------------------------------------------------------- + +testCases :: [FilePath] +testCases = [ "randtest1", "randtest2", "randtest3", + "rfctest1", "rfctest2", "rfctest3", + "zerotest1", "zerotest2", "zerotest3" ] + +buildGoldTestCases :: IO TestTree +buildGoldTestCases = + do trees <- mapM buildGoldTest testCases + return (testGroup "Decompression Tests" trees) + +buildGoldTest :: FilePath -> IO TestTree +buildGoldTest test = + do let compressedFile = "test" "test-cases" test <.> "z" + goldFile = "test" "test-cases" test <.> "gold" + compressedBStr <- readFile compressedFile + goldBStr <- readFile goldFile + return (testCase (toTestCaseName test) + (assertEqual test (Right goldBStr) (decompress compressedBStr))) + +toTestCaseName :: FilePath -> String +toTestCaseName fpath = prefix ++ suffix + where + prefix | "zero" `isPrefixOf` fpath = "Zero test #" + | "rand" `isPrefixOf` fpath = "Random test #" + | "rfc" `isPrefixOf` fpath = "RFC test #" + | otherwise = error "Bad test case prefix." + suffix = [last fpath] + +-- ----------------------------------------------------------------------------- + +zlibTests :: IO TestTree +zlibTests = + do decompTests <- buildGoldTestCases + return $ testGroup "DEFLATE / ZLib Algorithm Testing" [ + testCase "RFC 1951 Code Generation Test" + (assertEqual "" (computeCodeValues rfcSimpleTestLengths) + rfcSimpleTestResults) + , testCase "Fixed Huffman lengths make right tree" + (assertEqual "" (computeCodeValues fixedHuffmanLengths) + fixedHuffmanResults) + , decompTests + ] + +main :: IO () +main = defaultMain =<< zlibTests +