pure-zlib (empty) → 0.3
raw patch · 10 files changed
+718/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, bytestring, containers, fingertree, monadLib, pure-zlib, test-framework, test-framework-hunit, test-framework-quickcheck2
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- pure-zlib.cabal +49/−0
- src/Codec/Compression/Zlib.hs +25/−0
- src/Codec/Compression/Zlib/Adler32.hs +34/−0
- src/Codec/Compression/Zlib/Deflate.hs +242/−0
- src/Codec/Compression/Zlib/HuffmanTree.hs +48/−0
- src/Codec/Compression/Zlib/Monad.hs +163/−0
- src/Codec/Compression/Zlib/OutputWindow.hs +68/−0
- test/Test.hs +57/−0
+ LICENSE view
@@ -0,0 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pure-zlib.cabal view
@@ -0,0 +1,49 @@+name: pure-zlib+version: 0.3+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.10+description: A Haskell-only implementation of the zlib / DEFLATE+ protocol. Currently only implements the decompression+ algorithm.++library+ default-language: Haskell2010+ ghc-options: -Wall+ hs-source-dirs: src+ build-depends:+ base >= 4.7 && < 5.0,+ bytestring >= 0.10 && < 0.11,+ containers >= 0.5 && < 0.7,+ fingertree >= 0.1 && < 0.3,+ monadLib >= 3.7 && < 3.9+ 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++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.7 && < 5.0,+ bytestring >= 0.10 && < 0.11,+ pure-zlib >= 0.3 && < 1.1,+ HUnit >= 1.2 && < 1.4,+ QuickCheck >= 2.7 && < 2.9,+ test-framework >= 0.8 && < 0.10,+ test-framework-hunit >= 0.3 && < 0.5,+ test-framework-quickcheck2 >= 0.3 && < 0.5
+ src/Codec/Compression/Zlib.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE MultiWayIf #-}+module Codec.Compression.Zlib(+ decompress+ )+ where++import Codec.Compression.Zlib.Deflate+import Codec.Compression.Zlib.Monad+import Data.Bits+import Data.ByteString.Lazy(ByteString)+import qualified Data.ByteString.Lazy as BS++decompress :: ByteString -> Maybe ByteString+decompress ifile =+ case BS.uncons ifile of+ Nothing -> error "Could not read CMF."+ Just (cmf, rest) ->+ case BS.uncons rest of+ Nothing -> error "Could not read FLG."+ Just (_, rest') ->+ let cm = cmf .&. 0x0F+ cinfo = cmf `shiftR` 4+ in if| cm /= 8 -> error "Non-DEFLATE compression method."+ | cinfo > 7 -> error "Window size too big."+ | otherwise -> runDeflateM inflate rest'
+ src/Codec/Compression/Zlib/Adler32.hs view
@@ -0,0 +1,34 @@+module Codec.Compression.Zlib.Adler32(+ AdlerState+ , initialAdlerState+ , advanceAdler+ , finalizeAdler+ )+ where++import Data.Bits+import Data.Word++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
@@ -0,0 +1,242 @@+{-# LANGUAGE MultiWayIf #-}+module Codec.Compression.Zlib.Deflate(+ inflate+ , computeCodeValues+ )+ where++import Codec.Compression.Zlib.HuffmanTree+import Codec.Compression.Zlib.Monad+import Control.Monad+import Data.Bits+import Data.ByteString.Lazy(ByteString)+import qualified Data.ByteString.Lazy as BS+import Data.Int+import Data.List+import Data.Map.Strict(Map)+import qualified Data.Map.Strict as Map+import Data.Word++inflate :: DeflateM (Maybe ByteString)+inflate =+ do isFinal <- inflateBlock+ if isFinal+ then do advanceToByte+ rest <- readRest+ ourAdler <- finalAdler+ result <- finalOutput+ let theirAdler = BS.foldl shiftAdd 0 rest+ if | BS.length rest /= 4 -> return Nothing+ | theirAdler /= ourAdler -> return Nothing+ | otherwise -> return (Just result)+ else inflate+ where shiftAdd x y = (x `shiftL` 8) .|. fromIntegral y++inflateBlock :: DeflateM Bool+inflateBlock =+ do bfinal <- nextBit+ btype <- nextBits 2+ case btype :: Word8 of+ 0 -> -- no compression+ do advanceToByte+ len <- nextWord16+ nlen <- nextWord16+ unless (len == complement nlen) $+ fail "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+ error ("Unacceptable BTYPE: " ++ show btype)+ where+ runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM ()+ runInflate litTree distTree =+ do code <- nextCode litTree+ if | code < 256 -> do emitByte (fromIntegral code)+ runInflate litTree distTree+ | code == 256 -> return ()+ | code > 256 -> do len <- getLength code+ distCode <- nextCode distTree+ dist <- getDistance distCode+ emitPastChunk dist len+ runInflate litTree distTree++-- -----------------------------------------------------------------------------++getCodeLengths :: HuffmanTree Int ->+ Int -> Int -> Int ->+ Map Int Int ->+ DeflateM (Map Int 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 =+ case Map.lookup c getLengthMap of+ Nothing -> error ("getLength for bad code: " ++ show c)+ Just m -> m++getLengthMap :: Map Int (DeflateM Int64)+getLengthMap = Map.fromList [+ (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 =+ case Map.lookup c getDistanceMap of+ Nothing -> error ("getDistance for bad code: " ++ show c)+ Just m -> m++getDistanceMap :: Map Int (DeflateM Int)+getDistanceMap = Map.fromList [+ (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)+ ]++-- -----------------------------------------------------------------------------++fixedLitTree :: HuffmanTree Int+fixedLitTree = computeHuffmanTree+ ([(x, 8) | x <- [0 .. 143]] +++ [(x, 9) | x <- [144 .. 255]] +++ [(x, 7) | x <- [256 .. 279]] +++ [(x, 8) | x <- [280 .. 287]])++fixedDistanceTree :: HuffmanTree Int+fixedDistanceTree = computeHuffmanTree [(x,5) | x <- [0..31]]++-- -----------------------------------------------------------------------------++computeHuffmanTree :: [(Int, Int)] -> HuffmanTree Int+computeHuffmanTree = createHuffmanTree . computeCodeValues++computeCodeValues :: Ord a => [(a, Int)] -> [(a, 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
@@ -0,0 +1,48 @@+module Codec.Compression.Zlib.HuffmanTree(+ HuffmanTree+ , createHuffmanTree+ , advanceTree+ )+ where++import Data.Bits++data HuffmanTree a = HuffmanNode (HuffmanTree a) (HuffmanTree a)+ | HuffmanValue a+ | HuffmanEmpty+ deriving (Show)++emptyHuffmanTree :: HuffmanTree a+emptyHuffmanTree = HuffmanEmpty++createHuffmanTree :: Show a => [(a, Int, Int)] -> HuffmanTree a+createHuffmanTree = foldr addHuffmanNode' emptyHuffmanTree+ where addHuffmanNode' (a, b, c) = addHuffmanNode a b c++addHuffmanNode :: Show a => a -> Int -> Int -> HuffmanTree a -> HuffmanTree a+addHuffmanNode val 0 _ (HuffmanNode _ _) =+ error ("Tried to add where the leaf is a node: " ++ show val)+addHuffmanNode _ 0 _ (HuffmanValue _) =+ error "Two values point to the same place!"+addHuffmanNode val 0 _ HuffmanEmpty =+ HuffmanValue val+addHuffmanNode val len code (HuffmanNode l r)+ | testBit code (len - 1) = HuffmanNode l (addHuffmanNode val (len - 1) code r)+ | otherwise = HuffmanNode (addHuffmanNode val (len - 1) code l) r+addHuffmanNode _ _ _ (HuffmanValue _) =+ error "HuffmanValue hit while inserting a value!"+addHuffmanNode val len code HuffmanEmpty =+ let newNode = addHuffmanNode val (len - 1) code HuffmanEmpty+ in if testBit code (len - 1)+ then HuffmanNode HuffmanEmpty newNode+ else HuffmanNode newNode HuffmanEmpty++advanceTree :: Bool -> HuffmanTree a -> Either (HuffmanTree a) a+advanceTree _ HuffmanEmpty = error "Tried to advance empty tree!"+advanceTree _ (HuffmanValue _) = error "Tried to advance empty value!"+advanceTree x (HuffmanNode l r) =+ case if x then r else l of+ HuffmanEmpty -> error "Advanced to empty tree!"+ HuffmanValue y -> Right y+ t -> Left t+
+ src/Codec/Compression/Zlib/Monad.hs view
@@ -0,0 +1,163 @@+module Codec.Compression.Zlib.Monad(+ DeflateM+ , runDeflateM+ -- * Getting data from the input stream.+ , nextBit+ , nextBits+ , nextByte+ , nextWord16+ , nextBlock+ , nextCode+ , readRest+ -- * Aligning+ , advanceToByte+ -- * Emitting data+ , emitByte+ , emitBlock+ , emitPastChunk+ -- * Getting output+ , finalAdler+ , finalOutput+ )+ where++import Codec.Compression.Zlib.Adler32+import Codec.Compression.Zlib.HuffmanTree+import Codec.Compression.Zlib.OutputWindow+import Control.Monad+import Data.Bits+import Data.ByteString.Lazy(ByteString)+import qualified Data.ByteString.Lazy as BS+import Data.Int+import Data.Word+import MonadLib+import MonadLib.Monads++data DecompressState = DecompressState {+ dcsNextBitNo :: Int+ , dcsCurByte :: Word8+ , dcsAdler32 :: AdlerState+ , dcsInput :: ByteString+ , dcsOutput :: OutputWindow+ }++type DeflateM = State DecompressState++initialState :: ByteString -> DecompressState+initialState bstr =+ case BS.uncons bstr of+ Nothing -> error "No compressed data to inflate."+ Just (f,rest) -> DecompressState 0 f initialAdlerState rest emptyWindow++runDeflateM :: Show a => DeflateM a -> ByteString -> a+runDeflateM m i = result+ where (result, _) = runState (initialState i) m++-- -----------------------------------------------------------------------------++nextBit :: DeflateM Bool+nextBit =+ do dcs <- get+ let v = dcsCurByte dcs `testBit` dcsNextBitNo dcs+ set $ advanceBit dcs+ return v+ where+ advanceBit dcs+ | dcsNextBitNo dcs == 7 =+ case BS.uncons (dcsInput dcs) of+ Nothing ->+ error "Bit required, but no bits available!"+ Just (nextb, rest) ->+ dcs{ dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest }+ | otherwise =+ dcs{ dcsNextBitNo = dcsNextBitNo dcs + 1 }++nextBits :: (Num a, Bits a) => Int -> DeflateM a+nextBits x+ | x < 1 = error "nextBits called with x < 1"+ | x == 1 = toNum `fmap` nextBit+ | otherwise = do cur <- toNum `fmap` nextBit+ rest <- nextBits (x - 1)+ return ((rest `shiftL` 1) .|. cur)+ where+ toNum False = 0+ toNum True = 1++nextByte :: DeflateM Word8+nextByte =+ do dcs <- get+ case BS.uncons (dcsInput dcs) of+ _ | dcsNextBitNo dcs /= 0 ->+ nextBits 8+ Nothing ->+ error "nextByte called with no more data."+ Just (nextb, rest) ->+ do set dcs{ dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest }+ return (dcsCurByte dcs)++nextWord16 :: DeflateM Word16+nextWord16 =+ do high <- fromIntegral `fmap` nextByte+ low <- fromIntegral `fmap` nextByte+ return ((high `shiftL` 8) .|. low)++nextBlock :: Integral a => a -> DeflateM ByteString+nextBlock amt =+ do dcs <- get+ unless (dcsNextBitNo dcs == 0) $+ fail "Can't get a block on a non-byte boundary."+ let curBlock = BS.cons (dcsCurByte dcs) (dcsInput dcs)+ (block, rest) = BS.splitAt (fromIntegral amt) curBlock+ case BS.uncons rest of+ Nothing ->+ fail "Not enough data left after nextBlock."+ Just (first, rest') ->+ do set dcs{ dcsNextBitNo = 0, dcsCurByte = first, dcsInput = rest' }+ return block++nextCode :: Show a => HuffmanTree a -> DeflateM a+nextCode tree =+ do b <- nextBit+ case advanceTree b tree of+ Left tree' -> nextCode tree'+ Right x -> return x++readRest :: DeflateM ByteString+readRest =+ do dcs <- get+ return (BS.cons (dcsCurByte dcs) (dcsInput dcs))++advanceToByte :: DeflateM ()+advanceToByte =+ do dcs <- get+ when (dcsNextBitNo dcs /= 0) $+ case BS.uncons (dcsInput dcs) of+ Nothing -> error "Advanced with no bytes left!"+ Just (nextb, rest) ->+ set dcs{ dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest }++emitByte :: Word8 -> DeflateM ()+emitByte b =+ do dcs <- get+ set dcs{ dcsOutput = dcsOutput dcs `addByte` b+ , dcsAdler32 = advanceAdler (dcsAdler32 dcs) b }++emitBlock :: ByteString -> DeflateM ()+emitBlock b =+ do dcs <- get+ set dcs { dcsOutput = dcsOutput dcs `addChunk` b+ , dcsAdler32 = BS.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 = BS.foldl advanceAdler (dcsAdler32 dcs) newChunk }++finalAdler :: DeflateM Word32+finalAdler = (finalizeAdler . dcsAdler32) `fmap` get++finalOutput :: DeflateM ByteString+finalOutput = (outByteString . dcsOutput) `fmap` get+
+ src/Codec/Compression/Zlib/OutputWindow.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Codec.Compression.Zlib.OutputWindow(+ OutputWindow+ , emptyWindow+ , addByte+ , addChunk+ , addOldChunk+ , outByteString+ )+ where++import Data.ByteString.Builder+import Data.ByteString.Lazy(ByteString)+import qualified Data.ByteString as SBS+import qualified Data.ByteString.Lazy as BS+import Data.Int+import Data.FingerTree+import Data.Foldable(foldMap)+import Data.Monoid+import Data.Word++data OutputWindow = OutputWindow {+ owCommitted :: FingerTree Int SBS.ByteString+ , owRecent :: Builder+ }++instance Monoid Int where+ mempty = 0+ mappend = (+)++instance Measured Int SBS.ByteString where+ measure = SBS.length++emptyWindow :: OutputWindow+emptyWindow = OutputWindow empty mempty++addByte :: OutputWindow -> Word8 -> OutputWindow+addByte ow b = ow{ owRecent = owRecent ow <> word8 b }++addChunk :: OutputWindow -> ByteString -> OutputWindow+addChunk ow bs = ow{ owRecent = owRecent ow <> lazyByteString bs }++addOldChunk :: OutputWindow -> Int -> Int64 -> (OutputWindow, ByteString)+addOldChunk ow dist len = (OutputWindow output (lazyByteString chunk), chunk)+ where+ output = owCommitted ow |> BS.toStrict (toLazyByteString (owRecent ow))+ dropAmt = measure output - dist+ (prev, sme) = split (> dropAmt) output+ s :< rest = viewl sme+ start = SBS.take (fromIntegral len) (SBS.drop (dropAmt-measure prev) s)+ len' = fromIntegral len - SBS.length start+ (m, rest') = split (> len') rest+ middle = BS.toStrict (toLazyByteString (outFinger m))+ end = case viewl rest' of+ EmptyL -> SBS.empty+ bs2 :< _ -> SBS.take (len' - measure m) bs2+ chunkInf = BS.fromChunks [start, middle, end] `BS.append` chunk+ chunk = BS.take len chunkInf++outFinger :: FingerTree Int SBS.ByteString -> Builder+outFinger = foldMap byteString++outByteString :: OutputWindow -> ByteString+outByteString ow = + toLazyByteString (outFinger (owCommitted ow) <> owRecent ow)++
+ test/Test.hs view
@@ -0,0 +1,57 @@+import Codec.Compression.Zlib.Deflate+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit(assertEqual)++rfcSimpleTestLengths :: [(Char, Int)]+rfcSimpleTestLengths = [+ ('A', 3)+ , ('B', 3)+ , ('C', 3)+ , ('D', 3)+ , ('E', 3)+ , ('F', 2)+ , ('G', 4)+ , ('H', 4)+ ]++rfcSimpleTestResults :: [(Char, Int, Int)]+rfcSimpleTestResults = [+ ('A', 3, 2) -- 010+ , ('B', 3, 3) -- 011+ , ('C', 3, 4) -- 100+ , ('D', 3, 5) -- 101+ , ('E', 3, 6) -- 110+ , ('F', 2, 0) -- 00+ , ('G', 4, 14) -- 1110+ , ('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++zlibTests :: Test+zlibTests =+ 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)+ ]++main :: IO ()+main = defaultMain [zlibTests]+