pure-zlib 0.6.5 → 0.6.6
raw patch · 12 files changed
+1121/−1119 lines, 12 filesdep ~basesetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
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/−254
- 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.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 +
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,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] + +
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 ->- 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<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 +