pure-zlib 0.6.6 → 0.6.7
raw patch · 12 files changed
+1121/−1121 lines, 12 filesdep ~base-compatsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base-compat
API changes (from Hackage documentation)
Files
- Benchmark.hs +35/−35
- Deflate.hs +40/−40
- LICENSE +30/−30
- Setup.hs +2/−2
- pure-zlib.cabal +90/−90
- src/Codec/Compression/Zlib.hs +58/−58
- src/Codec/Compression/Zlib/Adler32.hs +34/−34
- src/Codec/Compression/Zlib/Deflate.hs +256/−256
- src/Codec/Compression/Zlib/HuffmanTree.hs +73/−73
- src/Codec/Compression/Zlib/Monad.hs +306/−306
- src/Codec/Compression/Zlib/OutputWindow.hs +99/−99
- test/Test.hs +98/−98
Benchmark.hs view
@@ -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"
Deflate.hs view
@@ -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
LICENSE view
@@ -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.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
pure-zlib.cabal view
@@ -1,90 +1,90 @@-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 - +name: pure-zlib+version: 0.6.7+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.12,+ 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.12,+ 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.12,+ 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.12,+ 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+
src/Codec/Compression/Zlib.hs view
@@ -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
src/Codec/Compression/Zlib/Adler32.hs view
@@ -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)++
src/Codec/Compression/Zlib/Deflate.hs view
@@ -1,256 +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) - | 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] - - +{-# 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]++
src/Codec/Compression/Zlib/HuffmanTree.hs view
@@ -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 #-}
src/Codec/Compression/Zlib/Monad.hs view
@@ -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<nextBit=" ++ show (dcsNextBitNo dcs) ++ "," ++ - "curByte=" ++ show (dcsCurByte dcs) ++ ",inputLen=" ++ - show (S.length (dcsInput dcs)) ++ ">" - --- ----------------------------------------------------------------------------- - -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 ())) +{-# 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<nextBit=" ++ show (dcsNextBitNo dcs) ++ "," +++ "curByte=" ++ show (dcsCurByte dcs) ++ ",inputLen=" +++ show (S.length (dcsInput dcs)) ++ ">"++-- -----------------------------------------------------------------------------++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 ()))
src/Codec/Compression/Zlib/OutputWindow.hs view
@@ -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)
test/Test.hs view
@@ -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+