diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -1,39 +1,87 @@ -import Codec.Compression.Zlib(ZlibDecoder(..), decompressIncremental) -import qualified Data.ByteString as S +import qualified CZlib +import qualified CZlib.Internal as CZlibIncremental +import qualified PureZlib + +import qualified Control.Monad.ST.Lazy as CM +import Criterion.Main +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified GHC.ST as GHC import Prelude hiding (readFile, writeFile) -import Criterion.Main testCases :: [String] -testCases = [ "randtest1", "randtest2", "randtest3", - "rfctest1", "rfctest2", "rfctest3", - "zerotest1", "zerotest2", "zerotest3", - "tor-list" ] +testCases = + [ "randtest1" + , "randtest2" + , "randtest3" + , "rfctest1" + , "rfctest2" + , "rfctest3" + , "zerotest1" + , "zerotest2" + , "zerotest3" + , "tor-list" + ] main :: IO () -main = defaultMain - [ - bgroup "decompression" $ flip fmap testCases $ \tc -> - env (getFiles tc) $ \ ~(zbstr, goldbstr) -> - bench tc $ whnf (runDecompression (L.toChunks zbstr) goldbstr) decompressIncremental - ] - where - getFiles tc = do - zbstr <- L.readFile $ "test/test-cases/" ++ tc ++ ".z" - goldbstr <- L.readFile $ "test/test-cases/" ++ tc ++ ".gold" - pure (zbstr, goldbstr) +main = + defaultMain + [ bgroup "decompression" $ + flip fmap testCases $ + \tc -> env (getFiles tc) $ + \ ~(zbstr, _) -> + bgroup + tc + [ bgroup + "normal" + [ bench "pure-zlib" $ whnf PureZlib.decompress zbstr + , bench "zlib" $ whnf CZlib.decompress zbstr + ] + , bgroup + "incremental" + [ bench "pure-zlib" $ whnf decompressIncrementalPure zbstr + , bench "zlib" $ whnf decompressIncrementalC zbstr + ] + ] + ] + where + getFiles tc = do + zbstr <- L.readFile $ "test/test-cases/" ++ tc ++ ".z" + goldbstr <- L.readFile $ "test/test-cases/" ++ tc ++ ".gold" + pure (zbstr, goldbstr) -runDecompression :: [S.ByteString] -> L.ByteString -> ZlibDecoder -> () -runDecompression ls real decoder = - case decoder of - Done | not (null ls) -> error "ERROR: Finished decompression with data left." - Done | not (L.null real) -> error "ERROR: Did not completely decompress file." - Done | otherwise -> () - DecompError e -> error ("ERROR: " ++ show e) - NeedMore f | (x:rest) <- ls -> runDecompression rest real (f x) - | otherwise -> error "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 error "Mismatch in decompression" +decompressIncrementalPure :: L.ByteString -> L.ByteString +decompressIncrementalPure input = GHC.runST $ do + initialState <- PureZlib.decompressIncremental + go initialState (L.toChunks input) [] + where + go decoder ls chunks = + case decoder of + PureZlib.NeedMore f + | (x : rest) <- ls -> do + nextState <- f x + go nextState rest chunks + | otherwise -> error "ERROR: Ran out of data mid-decompression." + PureZlib.Chunk c m -> do + nextState <- m + go nextState ls (c : chunks) + PureZlib.Done | not (null ls) -> error "ERROR: Finished decompression with data left." + PureZlib.Done | otherwise -> return (L.fromChunks (reverse chunks)) + PureZlib.DecompError e -> error ("ERROR: " ++ show e) + +decompressIncrementalC :: L.ByteString -> L.ByteString +decompressIncrementalC input = CM.runST $ go (CZlibIncremental.decompressST CZlibIncremental.zlibFormat CZlibIncremental.defaultDecompressParams) (L.toChunks input) [] + where + go decoder ls chunks = case decoder of + CZlibIncremental.DecompressInputRequired f + | (x : rest) <- ls -> do + next <- f x + go next rest chunks + | otherwise -> error "ERROR: Ran out of data mid-decompression." + CZlibIncremental.DecompressOutputAvailable c kont -> do + next <- kont + go next ls (c : chunks) + CZlibIncremental.DecompressStreamEnd leftovers + | not (S.null leftovers) -> error "ERROR: Finished decompression with data left." + | otherwise -> pure $ L.fromChunks $ reverse chunks + CZlibIncremental.DecompressStreamError e -> error ("ERROR: " ++ show e) diff --git a/Deflate.hs b/Deflate.hs --- a/Deflate.hs +++ b/Deflate.hs @@ -1,40 +1,48 @@ -import Codec.Compression.Zlib(ZlibDecoder(..), decompressIncremental) -import Control.Monad(unless) -import qualified Data.ByteString as S +{-# LANGUAGE RankNTypes #-} + +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 Data.List (isSuffixOf) +import GHC.IO (stToIO) +import GHC.Prim (RealWorld) +import GHC.ST (ST) +import System.Environment (getArgs) +import System.IO (Handle, IOMode (..), hClose, openFile) 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]" +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 +runDecompression :: Handle -> [S.ByteString] -> ST RealWorld (ZlibDecoder RealWorld) -> IO () +runDecompression hndl ls decoder = do + nextState <- stToIO decoder + case nextState 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 + S.hPut hndl c + runDecompression hndl ls m diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/pure-zlib.cabal b/pure-zlib.cabal --- a/pure-zlib.cabal +++ b/pure-zlib.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: pure-zlib -version: 0.6.8 +version: 0.8.0 synopsis: A Haskell-only implementation of zlib / DEFLATE homepage: http://github.com/GaloisInc/pure-zlib license: BSD3 @@ -8,12 +9,18 @@ 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 +tested-with: + GHC==8.0.2, + GHC==8.2.2, + GHC==8.4.4, + GHC==8.6.5, + GHC==8.8.4, + GHC==8.10.4 library default-language: Haskell2010 @@ -25,7 +32,9 @@ base-compat >= 0.9.1 && < 0.12, bytestring >= 0.10 && < 0.11, bytestring-builder >= 0.10 && < 0.11, - containers >= 0.5 && < 0.7 + containers >= 0.5 && < 0.7, + vector, + primitive if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* exposed-modules: @@ -35,8 +44,6 @@ Codec.Compression.Zlib.HuffmanTree, Codec.Compression.Zlib.Monad, Codec.Compression.Zlib.OutputWindow - other-modules: - Codec.Compression.Zlib.FingerTree default-extensions: BangPatterns, DeriveDataTypeable, @@ -52,6 +59,7 @@ base >= 4.6 && < 5.0, base-compat >= 0.9.1 && < 0.12, bytestring >= 0.10 && < 0.11, + ghc-prim, pure-zlib test-suite test-zlib @@ -84,7 +92,12 @@ bytestring >= 0.10 && < 0.11, criterion >= 1.5, pure-zlib, + zlib, time >= 1.4.2 && < 1.11 + mixins: + pure-zlib (Codec.Compression.Zlib as PureZlib), + zlib (Codec.Compression.Zlib as CZlib), + zlib (Codec.Compression.Zlib.Internal as CZlib.Internal) source-repository head type: git diff --git a/src/Codec/Compression/Zlib.hs b/src/Codec/Compression/Zlib.hs --- a/src/Codec/Compression/Zlib.hs +++ b/src/Codec/Compression/Zlib.hs @@ -1,58 +1,69 @@ {-# 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) +module Codec.Compression.Zlib ( + DecompressionError (..), + ZlibDecoder (NeedMore, Chunk, Done, DecompError), + decompress, + decompressIncremental, +) where + +import Codec.Compression.Zlib.Deflate (inflate) +import Codec.Compression.Zlib.Monad ( + DecompressionError (..), + DeflateM, + ZlibDecoder (..), + nextByte, + raise, + runDeflateM, + ) +import Control.Monad (replicateM_, unless, when) +import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.)) +import qualified Data.ByteString as S +import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import qualified Data.ByteString.Lazy as L -import Data.Semigroup ((<>)) -import Data.Word(Word16) -import Prelude() -import Prelude.Compat +import Data.Word (Word16) +import GHC.ST (ST, runST) +import Prelude.Compat +import Prelude () -decompressIncremental :: ZlibDecoder +decompressIncremental :: ST s (ZlibDecoder s) decompressIncremental = runDeflateM inflateWithHeaders decompress :: L.ByteString -> Either DecompressionError L.ByteString -decompress ifile = run decompressIncremental (L.toChunks ifile) mempty +decompress ifile = runST $ do + base <- decompressIncremental + run base (L.toChunks ifile) mempty where + run :: ZlibDecoder s -> [S.ByteString] -> Builder -> ST s (Either DecompressionError L.ByteString) 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.") + return (Left (DecompressionError "Ran out of data mid-decompression 2.")) + run (NeedMore f) (first : rest) acc = do + nextState <- f first + run nextState rest acc + run (Chunk c m) ls acc = do + nextState <- m + run nextState ls (acc <> byteString c) + run Done [] acc = + return (Right (toLazyByteString acc)) + run Done (_ : _) _ = + return (Left (DecompressionError "Finished with data remaining.")) run (DecompError e) _ _ = - Left e + return (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 +inflateWithHeaders :: DeflateM s () +inflateWithHeaders = do + cmf <- nextByte + flg <- nextByte + let both = fromIntegral cmf `shiftL` 8 .|. fromIntegral flg + cm = cmf .&. 0x0f + cinfo = cmf `shiftR` 4 + fdict = testBit flg 5 + -- flevel = flg `shiftR` 6 + unless ((both :: Word16) `mod` 31 == 0) $ + raise (HeaderError "Header checksum failed") + unless (cm == 8) $ + raise (HeaderError ("Bad compression method: " ++ show cm)) + unless (cinfo <= 7) $ + raise (HeaderError ("Window size too big: " ++ show cinfo)) + when fdict $ replicateM_ 4 nextByte -- just skip them for now (FIXME) + inflate diff --git a/src/Codec/Compression/Zlib/Adler32.hs b/src/Codec/Compression/Zlib/Adler32.hs --- a/src/Codec/Compression/Zlib/Adler32.hs +++ b/src/Codec/Compression/Zlib/Adler32.hs @@ -1,20 +1,21 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} -module Codec.Compression.Zlib.Adler32( - AdlerState - , initialAdlerState - , advanceAdler - , advanceAdlerBlock - , finalizeAdler - ) - where -import Data.Bits(shiftL, (.|.)) -import qualified Data.ByteString.Lazy as L -import GHC.Exts ( Word#, plusWord#, remWord# ) -import GHC.Word ( Word8(..), Word32(..) ) +module Codec.Compression.Zlib.Adler32 ( + AdlerState, + initialAdlerState, + advanceAdler, + advanceAdlerBlock, + finalizeAdler, +) where -data AdlerState = AdlerState { _adlerA :: Word#, _adlerB :: Word# } +import Data.Bits (shiftL, (.|.)) +import qualified Data.ByteString as S +import GHC.Exts (Word#, plusWord#, remWord#) +import GHC.Word (Word32 (..), Word8 (..)) +data AdlerState = AdlerState {_adlerA :: Word#, _adlerB :: Word#} + initialAdlerState :: AdlerState initialAdlerState = AdlerState 1## 0## @@ -33,24 +34,24 @@ {-# INLINE advanceNoMod #-} -- The block must be less than 5552 bytes long in this case -advanceAdlerLimited :: AdlerState -> L.ByteString -> AdlerState +advanceAdlerLimited :: AdlerState -> S.ByteString -> AdlerState advanceAdlerLimited !state !bl = AdlerState stateA' stateB' where - !(AdlerState stateA stateB) = L.foldl' advanceNoMod state bl + !(AdlerState stateA stateB) = S.foldl' advanceNoMod state bl stateA' = stateA `remWord#` 65521## stateB' = stateB `remWord#` 65521## -advanceAdlerBlock :: AdlerState -> L.ByteString -> AdlerState +advanceAdlerBlock :: AdlerState -> S.ByteString -> AdlerState advanceAdlerBlock !state !bl - | L.length bl == 0 = state - | L.length bl == 1 = advanceAdler state (L.head bl) - | L.length bl < 5552 = advanceAdlerLimited state bl + | S.length bl == 0 = state + | S.length bl == 1 = advanceAdler state (S.head bl) + | S.length bl < 5552 = advanceAdlerLimited state bl | otherwise = advanceAdlerBlock (advanceAdlerBlock state first5551) rest where - (!first5551, !rest) = L.splitAt 5551 bl + (!first5551, !rest) = S.splitAt 5551 bl finalizeAdler :: AdlerState -> Word32 finalizeAdler (AdlerState a b) = high .|. low - where - high = (W32# b) `shiftL` 16 - low = W32# a + where + high = (W32# b) `shiftL` 16 + low = W32# a diff --git a/src/Codec/Compression/Zlib/Deflate.hs b/src/Codec/Compression/Zlib/Deflate.hs --- a/src/Codec/Compression/Zlib/Deflate.hs +++ b/src/Codec/Compression/Zlib/Deflate.hs @@ -1,256 +1,292 @@ {-# 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) +module Codec.Compression.Zlib.Deflate ( + inflate, + computeCodeValues, +) where + +import Codec.Compression.Zlib.HuffmanTree ( + HuffmanTree, + createHuffmanTree, + ) +import Codec.Compression.Zlib.Monad ( + DecompressionError (..), + DeflateM, + advanceToByte, + emitBlock, + emitByte, + emitPastChunk, + finalAdler, + finalize, + moveWindow, + nextBits, + nextBlock, + nextCode, + nextWord16, + nextWord32, + raise, + ) +import Control.Monad (replicateM, unless) +import Data.Array (Array, array, (!)) +import Data.Bits (complement, shiftL) +import Data.Int (Int64) +import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as Map -import Data.Word(Word8) -import Numeric(showHex) +import Data.List (sortBy) +import Data.Word (Word8) +import Numeric (showHex) -inflate :: DeflateM () -inflate = - do fixedLit <- buildFixedLitTree - fixedDist <- buildFixedDistanceTree - go fixedLit fixedDist +inflate :: DeflateM s () +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 + 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 "")) + 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)) +inflateBlock :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s Bool +inflateBlock fixedLitTree fixedDistanceTree = do + bfinal <- (== (1 :: Word8)) `fmap` nextBits 1 + btype <- nextBits 2 + case btype :: Word8 of + 0 -> do + -- no compression + advanceToByte + len <- nextWord16 + nlen <- nextWord16 + unless (len == complement nlen) $ + raise (FormatError "Len/nlen mismatch in uncompressed block.") + emitBlock =<< nextBlock len + return bfinal + 1 -> do + -- compressed with fixed Huffman codes + runInflate fixedLitTree fixedDistanceTree + return bfinal + 2 -> do + -- compressed with dynamic Huffman codes + 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 + runInflate :: HuffmanTree Int -> HuffmanTree Int -> DeflateM s () + 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 (fromIntegral len) + moveWindow + runInflate litTree distTree -- ----------------------------------------------------------------------------- -getCodeLengths :: HuffmanTree Int -> - Int -> Int -> Int -> - IntMap Int -> - DeflateM (IntMap Int) +getCodeLengths :: + HuffmanTree Int -> + Int -> + Int -> + Int -> + IntMap Int -> + DeflateM s (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)) + | 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 -> do + -- copy the previous code length 3 - 6 times + num <- (3 +) `fmap` nextBits 2 + getCodeLengths tree (n + num) maxl prev (addNTimes n num prev acc) + | code == 17 -> do + -- repeat a code length of 0 for 3 - 10 times + num <- (3 +) `fmap` nextBits 3 + getCodeLengths tree (n + num) maxl 0 (addNTimes n num 0 acc) + | code == 18 -> do + -- repeat a code length of 0 for 11 - 138 times + 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..] + let idxs = take count [idx ..] vals = replicate count val - in Map.union old (Map.fromList (zip idxs vals)) + in Map.union old (Map.fromList (zip idxs vals)) -- ----------------------------------------------------------------------------- -getLength :: Int -> DeflateM Int64 +getLength :: Int -> DeflateM s 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) - ] +lengthArray :: Array Int (DeflateM s 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 :: Int -> DeflateM s 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) - ] +distanceArray :: Array Int (DeflateM s 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]]) +buildFixedLitTree :: DeflateM s (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]] +buildFixedDistanceTree :: DeflateM s (HuffmanTree Int) +buildFixedDistanceTree = computeHuffmanTree [(x, 5) | x <- [0 .. 31]] -- ----------------------------------------------------------------------------- -computeHuffmanTree :: [(Int, Int)] -> DeflateM (HuffmanTree Int) +computeHuffmanTree :: [(Int, Int)] -> DeflateM s (HuffmanTree Int) computeHuffmanTree initialData = case createHuffmanTree (computeCodeValues initialData) of - Left err -> raise (HuffmanTreeError err) - Right x -> return x + 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 +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 + 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 + lenTree = Map.fromList valsSort codeTree = step3 (map fst valsSort) nextcode Map.empty - maxBits = maximum (map snd valsSort) - codes = Map.intersectionWith (,) lenTree codeTree + 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) + 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 + 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 + ct' = Map.insert n ncLen ct + nc' = Map.insert len (ncLen + 1) nc + in if len == 0 + then step3 rest nc ct else step3 rest nc' ct' codeLengthOrder :: [Int] codeLengthOrder = [16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15] - - diff --git a/src/Codec/Compression/Zlib/FingerTree.hs b/src/Codec/Compression/Zlib/FingerTree.hs deleted file mode 100644 --- a/src/Codec/Compression/Zlib/FingerTree.hs +++ /dev/null @@ -1,680 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveGeneric #-} ------------------------------------------------------------------------------ --- | --- Module : Data.FingerTree --- Copyright : (c) Ross Paterson, Ralf Hinze 2006 --- License : BSD-style --- Maintainer : R.Paterson@city.ac.uk --- Stability : experimental --- Portability : non-portable (MPTCs and functional dependencies) --- --- A general sequence representation with arbitrary annotations, for --- use as a base for implementations of various collection types, as --- described in section 4 of --- --- * Ralf Hinze and Ross Paterson, --- \"Finger trees: a simple general-purpose data structure\", --- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. --- --- --- For a directly usable sequence type, see @Data.Sequence@, which is --- a specialization of this structure. --- --- An amortized running time is given for each operation, with /n/ --- referring to the length of the sequence. These bounds hold even in --- a persistent (shared) setting. --- --- /Note/: Many of these operations have the same names as similar --- operations on lists in the "Prelude". The ambiguity may be resolved --- using either qualification or the @hiding@ clause. --- ------------------------------------------------------------------------------ - -module Codec.Compression.Zlib.FingerTree ( - FingerTree, - Measured(..), - -- * Construction - empty, - (|>), - -- ** Examining the ends - dropTakeCombine, - -- ** Splitting - -- | These functions are special cases of 'search'. - split, - -- * Example - -- $example - toBuilder - ) where - -import Prelude hiding (null, reverse) -import GHC.Generics -import qualified Data.ByteString as S -import Data.ByteString.Builder(Builder, byteString) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Internal as L - -type Measure = Int - -infixr 5 >< -infixr 5 <|, :< -infixl 5 |>, :> - --- | View of the left end of a sequence. -data ViewL s a - = EmptyL -- ^ empty sequence - | a :< s a -- ^ leftmost element and the rest of the sequence - deriving (Eq, Ord, Show, Read, Generic) - --- | View of the right end of a sequence. -data ViewR s a - = EmptyR -- ^ empty sequence - | s a :> a -- ^ the sequence minus the rightmost element, - -- and the rightmost element - deriving (Eq, Ord, Show, Read, Generic) - -instance (Functor s) => Functor (ViewL s) where - fmap _ EmptyL = EmptyL - fmap f (x :< xs) = f x :< fmap f xs - -instance (Functor s) => Functor (ViewR s) where - fmap _ EmptyR = EmptyR - fmap f (xs :> x) = fmap f xs :> f x - -instance (Measured a) => Semigroup (FingerTree a) where - (<>) = (><) - --- | 'empty' and '><'. -instance (Measured a) => Monoid (FingerTree a) where - mempty = empty - mappend = (><) - -instance Measured S.ByteString where - measure = S.length - {-# INLINE measure #-} - --- Explicit Digit type (Exercise 1) - -data Digit a - = One a - | Two a a - | Three a a a - | Four a a a a - deriving (Show) - -------------------- --- 4.1 Measurements -------------------- - --- | Things that can be measured. -class Measured a where - measure :: a -> Measure - -instance (Measured a) => Measured (Digit a) where - measure (One a1) = measure a1 - measure (Two a1 a2) = measure a1 + measure a2 - measure (Three a1 a2 a3) = measure a1 + measure a2 + measure a3 - measure (Four a1 a2 a3 a4) = measure a1 + measure a2 + measure a3 + measure a4 - ---------------------------- --- 4.2 Caching measurements ---------------------------- - -data Node a = Node2 !Measure a a | Node3 !Measure a a a - deriving (Show) - -node2 :: (Measured a) => a -> a -> Node a -node2 a b = Node2 (measure a + measure b) a b - -node3 :: (Measured a) => a -> a -> a -> Node a -node3 a b c = Node3 (measure a + measure b + measure c) a b c - -instance Measured (Node a) where - measure (Node2 v _ _) = v - measure (Node3 v _ _ _) = v - -nodeToDigit :: Node a -> Digit a -nodeToDigit (Node2 _ a b) = Two a b -nodeToDigit (Node3 _ a b c) = Three a b c - --- | A representation of a sequence of values of type @a@, allowing --- access to the ends in constant time, and append and split in time --- logarithmic in the size of the smaller piece. --- --- The collection is also parameterized by a measure type @v@, which --- is used to specify a position in the sequence for the 'split' operation. --- The types of the operations enforce the constraint @'Measured' v a@, --- which also implies that the type @v@ is determined by @a@. --- --- A variety of abstract data types can be implemented by using different --- element types and measurements. -data FingerTree a - = Empty - | Single a - | Deep !Measure !(Digit a) (FingerTree (Node a)) !(Digit a) - deriving (Show) - -deep :: (Measured a) => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a -deep pr m sf = - Deep ((measure pr + measure m) + measure sf) pr m sf - --- | /O(1)/. The cached measure of a tree. -instance (Measured a) => Measured (FingerTree a) where - measure Empty = 0 - measure (Single x) = measure x - measure (Deep v _ _ _) = v - ------------------------------------------------------ --- 4.3 Construction, deconstruction and concatenation ------------------------------------------------------ - --- | /O(1)/. The empty sequence. -empty :: Measured a => FingerTree a -empty = Empty - --- | /O(1)/. Add an element to the left end of a sequence. --- Mnemonic: a triangle with the single element at the pointy end. -(<|) :: (Measured a) => a -> FingerTree a -> FingerTree a -a <| Empty = Single a -a <| Single b = deep (One a) Empty (One b) -a <| Deep v (Four b c d e) m sf = m `seq` - Deep (measure a + v) (Two a b) (node3 c d e <| m) sf -a <| Deep v pr m sf = - Deep (measure a + v) (consDigit a pr) m sf - -consDigit :: a -> Digit a -> Digit a -consDigit a (One b) = Two a b -consDigit a (Two b c) = Three a b c -consDigit a (Three b c d) = Four a b c d -consDigit _ (Four _ _ _ _) = illegal_argument "consDigit" - --- | /O(1)/. Add an element to the right end of a sequence. --- Mnemonic: a triangle with the single element at the pointy end. -(|>) :: (Measured a) => FingerTree a -> a -> FingerTree a -Empty |> a = Single a -Single a |> b = deep (One a) Empty (One b) -Deep v pr m (Four a b c d) |> e = m `seq` - Deep (v + measure e) pr (m |> node3 a b c) (Two d e) -Deep v pr m sf |> x = - Deep (v + measure x) pr m (snocDigit sf x) - -snocDigit :: Digit a -> a -> Digit a -snocDigit (One a) b = Two a b -snocDigit (Two a b) c = Three a b c -snocDigit (Three a b c) d = Four a b c d -snocDigit (Four _ _ _ _) _ = illegal_argument "snocDigit" - --- | /O(1)/. Analyse the left end of a sequence. -viewl :: (Measured a) => FingerTree a -> ViewL FingerTree a -viewl Empty = EmptyL -viewl (Single x) = x :< Empty -viewl (Deep _ (One x) m sf) = x :< rotL m sf -viewl (Deep _ pr m sf) = lheadDigit pr :< deep (ltailDigit pr) m sf - -dropTakeCombine :: Int -> Int -> FingerTree S.ByteString -> L.ByteString -dropTakeCombine !amountToSkip !amountToKeep !tree = - -- NB: we run this right after calling split, so on we shouldn't ever be in a situation where - -- the size of the first chunk is less than `amountToSkip`; if that does happy, split pushed - -- us to the wrong place. - case tree of - Empty -> L.empty - Single x -> go amountToKeep (Single (S.drop amountToSkip x)) - Deep _ (One x) m sf -> go amountToKeep (Deep 0 (One (S.drop amountToSkip x)) m sf) - Deep _ (Two x r) m sf -> go amountToKeep (Deep 0 (Two (S.drop amountToSkip x) r) m sf) - Deep _ (Three x r s) m sf -> go amountToKeep (Deep 0 (Three (S.drop amountToSkip x) r s) m sf) - Deep _ (Four x r s t) m sf -> go amountToKeep (Deep 0 (Four (S.drop amountToSkip x) r s t) m sf) - where - go 0 _ = L.empty - go left ftr = - case ftr of - Empty -> L.empty - Single x -> L.Chunk (S.take left x) L.Empty - Deep _ (One x) m sf -> keepSection left x (rotL m sf) - Deep _ (Two x r) m sf -> keepSection left x (Deep 0 (One r) m sf) - Deep _ (Three x r s) m sf -> keepSection left x (Deep 0 (Two r s) m sf) - Deep _ (Four x r s t) m sf -> keepSection left x (Deep 0 (Three r s t) m sf) - - keepSection left chunk rest - | S.length chunk >= left = L.Chunk (S.take left chunk) L.Empty - | otherwise = L.Chunk chunk (go (left - S.length chunk) rest) - -rotL :: (Measured a) => FingerTree (Node a) -> Digit a -> FingerTree a -rotL m sf = case viewl m of - EmptyL -> digitToTree sf - a :< m' -> Deep (measure m + measure sf) (nodeToDigit a) m' sf - -lheadDigit :: Digit a -> a -lheadDigit (One a) = a -lheadDigit (Two a _) = a -lheadDigit (Three a _ _) = a -lheadDigit (Four a _ _ _) = a - -ltailDigit :: Digit a -> Digit a -ltailDigit (One _) = illegal_argument "ltailDigit" -ltailDigit (Two _ b) = One b -ltailDigit (Three _ b c) = Two b c -ltailDigit (Four _ b c d) = Three b c d - --- | /O(1)/. Analyse the right end of a sequence. -viewr :: (Measured a) => FingerTree a -> ViewR FingerTree a -viewr Empty = EmptyR -viewr (Single x) = Empty :> x -viewr (Deep _ pr m (One x)) = rotR pr m :> x -viewr (Deep _ pr m sf) = deep pr m (rtailDigit sf) :> rheadDigit sf - -rotR :: (Measured a) => Digit a -> FingerTree (Node a) -> FingerTree a -rotR pr m = case viewr m of - EmptyR -> digitToTree pr - m' :> a -> Deep (measure pr + measure m) pr m' (nodeToDigit a) - -rheadDigit :: Digit a -> a -rheadDigit (One a) = a -rheadDigit (Two _ b) = b -rheadDigit (Three _ _ c) = c -rheadDigit (Four _ _ _ d) = d - -rtailDigit :: Digit a -> Digit a -rtailDigit (One _) = illegal_argument "rtailDigit" -rtailDigit (Two a _) = One a -rtailDigit (Three a b _) = Two a b -rtailDigit (Four a b c _) = Three a b c - -digitToTree :: (Measured a) => Digit a -> FingerTree a -digitToTree (One a) = Single a -digitToTree (Two a b) = deep (One a) Empty (One b) -digitToTree (Three a b c) = deep (Two a b) Empty (One c) -digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d) - ----------------- --- Concatenation ----------------- - --- | /O(log(min(n1,n2)))/. Concatenate two sequences. -(><) :: (Measured a) => FingerTree a -> FingerTree a -> FingerTree a -(><) = appendTree0 - -appendTree0 :: (Measured a) => FingerTree a -> FingerTree a -> FingerTree a -appendTree0 Empty xs = - xs -appendTree0 xs Empty = - xs -appendTree0 (Single x) xs = - x <| xs -appendTree0 xs (Single x) = - xs |> x -appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2 - -addDigits0 :: (Measured a) => FingerTree (Node a) -> Digit a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a) -addDigits0 m1 (One a) (One b) m2 = - appendTree1 m1 (node2 a b) m2 -addDigits0 m1 (One a) (Two b c) m2 = - appendTree1 m1 (node3 a b c) m2 -addDigits0 m1 (One a) (Three b c d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 -addDigits0 m1 (One a) (Four b c d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits0 m1 (Two a b) (One c) m2 = - appendTree1 m1 (node3 a b c) m2 -addDigits0 m1 (Two a b) (Two c d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 -addDigits0 m1 (Two a b) (Three c d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits0 m1 (Two a b) (Four c d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits0 m1 (Three a b c) (One d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 -addDigits0 m1 (Three a b c) (Two d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits0 m1 (Three a b c) (Three d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits0 m1 (Three a b c) (Four d e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits0 m1 (Four a b c d) (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits0 m1 (Four a b c d) (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits0 m1 (Four a b c d) (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits0 m1 (Four a b c d) (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 - -appendTree1 :: (Measured a) => FingerTree a -> a -> FingerTree a -> FingerTree a -appendTree1 Empty a xs = - a <| xs -appendTree1 xs a Empty = - xs |> a -appendTree1 (Single x) a xs = - x <| a <| xs -appendTree1 xs a (Single x) = - xs |> a |> x -appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 - -addDigits1 :: (Measured a) => FingerTree (Node a) -> Digit a -> a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a) -addDigits1 m1 (One a) b (One c) m2 = - appendTree1 m1 (node3 a b c) m2 -addDigits1 m1 (One a) b (Two c d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 -addDigits1 m1 (One a) b (Three c d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits1 m1 (One a) b (Four c d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits1 m1 (Two a b) c (One d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 -addDigits1 m1 (Two a b) c (Two d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits1 m1 (Two a b) c (Three d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits1 m1 (Two a b) c (Four d e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits1 m1 (Three a b c) d (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits1 m1 (Three a b c) d (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits1 m1 (Three a b c) d (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits1 m1 (Three a b c) d (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits1 m1 (Four a b c d) e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits1 m1 (Four a b c d) e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits1 m1 (Four a b c d) e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits1 m1 (Four a b c d) e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 - -appendTree2 :: (Measured a) => FingerTree a -> a -> a -> FingerTree a -> FingerTree a -appendTree2 Empty a b xs = - a <| b <| xs -appendTree2 xs a b Empty = - xs |> a |> b -appendTree2 (Single x) a b xs = - x <| a <| b <| xs -appendTree2 xs a b (Single x) = - xs |> a |> b |> x -appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 - -addDigits2 :: (Measured a) => FingerTree (Node a) -> Digit a -> a -> a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a) -addDigits2 m1 (One a) b c (One d) m2 = - appendTree2 m1 (node2 a b) (node2 c d) m2 -addDigits2 m1 (One a) b c (Two d e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits2 m1 (One a) b c (Three d e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits2 m1 (One a) b c (Four d e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits2 m1 (Two a b) c d (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits2 m1 (Two a b) c d (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits2 m1 (Two a b) c d (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits2 m1 (Two a b) c d (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits2 m1 (Three a b c) d e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits2 m1 (Three a b c) d e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits2 m1 (Three a b c) d e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits2 m1 (Three a b c) d e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits2 m1 (Four a b c d) e f (One g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits2 m1 (Four a b c d) e f (Two g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits2 m1 (Four a b c d) e f (Three g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 - -appendTree3 :: (Measured a) => FingerTree a -> a -> a -> a -> FingerTree a -> FingerTree a -appendTree3 Empty a b c xs = - a <| b <| c <| xs -appendTree3 xs a b c Empty = - xs |> a |> b |> c -appendTree3 (Single x) a b c xs = - x <| a <| b <| c <| xs -appendTree3 xs a b c (Single x) = - xs |> a |> b |> c |> x -appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 - -addDigits3 :: (Measured a) => FingerTree (Node a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a) -addDigits3 m1 (One a) b c d (One e) m2 = - appendTree2 m1 (node3 a b c) (node2 d e) m2 -addDigits3 m1 (One a) b c d (Two e f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits3 m1 (One a) b c d (Three e f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits3 m1 (One a) b c d (Four e f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits3 m1 (Two a b) c d e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits3 m1 (Two a b) c d e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits3 m1 (Two a b) c d e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits3 m1 (Two a b) c d e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits3 m1 (Three a b c) d e f (One g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits3 m1 (Three a b c) d e f (Two g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits3 m1 (Three a b c) d e f (Three g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 -addDigits3 m1 (Four a b c d) e f g (One h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits3 m1 (Four a b c d) e f g (Two h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 -addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 - -appendTree4 :: (Measured a) => FingerTree a -> a -> a -> a -> a -> FingerTree a -> FingerTree a -appendTree4 Empty a b c d xs = - a <| b <| c <| d <| xs -appendTree4 xs a b c d Empty = - xs |> a |> b |> c |> d -appendTree4 (Single x) a b c d xs = - x <| a <| b <| c <| d <| xs -appendTree4 xs a b c d (Single x) = - xs |> a |> b |> c |> d |> x -appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) = - deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 - -addDigits4 :: (Measured a) => FingerTree (Node a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree (Node a) -> FingerTree (Node a) -addDigits4 m1 (One a) b c d e (One f) m2 = - appendTree2 m1 (node3 a b c) (node3 d e f) m2 -addDigits4 m1 (One a) b c d e (Two f g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits4 m1 (One a) b c d e (Three f g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits4 m1 (One a) b c d e (Four f g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits4 m1 (Two a b) c d e f (One g) m2 = - appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 -addDigits4 m1 (Two a b) c d e f (Two g h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits4 m1 (Two a b) c d e f (Three g h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 -addDigits4 m1 (Three a b c) d e f g (One h) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 -addDigits4 m1 (Three a b c) d e f g (Two h i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 -addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 -addDigits4 m1 (Four a b c d) e f g h (One i) m2 = - appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 -addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 -addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 -addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = - appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 - ----------------- --- 4.4 Splitting ----------------- - --- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate --- on the accumulated measure of the prefix changes from 'False' to 'True'. --- --- For predictable results, one should ensure that there is only one such --- point, i.e. that the predicate is /monotonic/. -split :: (Measured a) => - Measure -> FingerTree a -> (FingerTree a, FingerTree a) -split _ Empty = (Empty, Empty) -split p xs - | (measure xs) >= p = (l, x <| r) - | otherwise = (xs, Empty) - where - Split l x r = splitTree p 0 xs - -data Split t a = Split t a t - -splitTree :: (Measured a) => - Measure -> Measure -> FingerTree a -> Split (FingerTree a) a -splitTree _ _ Empty = illegal_argument "splitTree" -splitTree _ _ (Single x) = Split Empty x Empty -splitTree p i (Deep _ pr m sf) - | vpr > p = let Split l x r = splitDigit p i pr - in Split (maybe Empty digitToTree l) x (deepL r m sf) - | vm > p = let Split ml xs mr = splitTree p vpr m - Split l x r = splitNode p (vpr + measure ml) xs - in Split (deepR pr ml l) x (deepL r mr sf) - | otherwise = let Split l x r = splitDigit p vm sf - in Split (deepR pr m l) x (maybe Empty digitToTree r) - where - vpr = i + measure pr - vm = vpr + measure m - -deepL :: (Measured a) => - Maybe (Digit a) -> FingerTree (Node a) -> Digit a -> FingerTree a -deepL Nothing m sf = rotL m sf -deepL (Just pr) m sf = deep pr m sf - -deepR :: (Measured a) => - Digit a -> FingerTree (Node a) -> Maybe (Digit a) -> FingerTree a -deepR pr m Nothing = rotR pr m -deepR pr m (Just sf) = deep pr m sf - -splitNode :: (Measured a) => - Measure -> Measure -> Node a -> Split (Maybe (Digit a)) a -splitNode p i (Node2 _ a b) - | va > p = Split Nothing a (Just (One b)) - | otherwise = Split (Just (One a)) b Nothing - where - va = i + measure a -splitNode p i (Node3 _ a b c) - | va > p = Split Nothing a (Just (Two b c)) - | vab > p = Split (Just (One a)) b (Just (One c)) - | otherwise = Split (Just (Two a b)) c Nothing - where - va = i + measure a - vab = va + measure b - -splitDigit :: (Measured a) => - Measure -> Measure -> Digit a -> Split (Maybe (Digit a)) a -splitDigit _ i (One a) = i `seq` Split Nothing a Nothing -splitDigit p i (Two a b) - | va > p = Split Nothing a (Just (One b)) - | otherwise = Split (Just (One a)) b Nothing - where - va = i + measure a -splitDigit p i (Three a b c) - | va > p = Split Nothing a (Just (Two b c)) - | vab > p = Split (Just (One a)) b (Just (One c)) - | otherwise = Split (Just (Two a b)) c Nothing - where - va = i + measure a - vab = va + measure b -splitDigit p i (Four a b c d) - | va > p = Split Nothing a (Just (Three b c d)) - | vab > p = Split (Just (One a)) b (Just (Two c d)) - | vabc > p = Split (Just (Two a b)) c (Just (One d)) - | otherwise = Split (Just (Three a b c)) d Nothing - where - va = i + measure a - vab = va + measure b - vabc = vab + measure c - ------------------- --- Transformations ------------------- - -illegal_argument :: String -> a -illegal_argument name = - error $ "Logic error: " ++ name ++ " called with illegal argument" - -{- $example - -Particular abstract data types may be implemented by defining -element types with suitable 'Measured' instances. - -(from section 4.5 of the paper) -Simple sequences can be implemented using a 'Sum' monoid as a measure: - -> newtype Elem a = Elem { getElem :: a } -> -> instance Measured (Sum Int) (Elem a) where -> measure (Elem _) = Sum 1 -> -> newtype Seq a = Seq (FingerTree (Sum Int) (Elem a)) - -Then the measure of a subsequence is simply its length. -This representation supports log-time extraction of subsequences: - -> take :: Int -> Seq a -> Seq a -> take k (Seq xs) = Seq (takeUntil (> Sum k) xs) -> -> drop :: Int -> Seq a -> Seq a -> drop k (Seq xs) = Seq (dropUntil (> Sum k) xs) - -The module @Data.Sequence@ is an optimized instantiation of this type. - -For further examples, see "Data.IntervalMap.FingerTree" and -"Data.PriorityQueue.FingerTree". - --} - -class ToBuilder a where - toBuilder :: a -> Builder - -instance ToBuilder S.ByteString where - toBuilder x = byteString x - -instance ToBuilder a => ToBuilder (FingerTree a) where - toBuilder ft = - case ft of - Empty -> mempty - Single x -> toBuilder x - Deep _ a b c -> toBuilder a <> toBuilder b <> toBuilder c - -instance ToBuilder a => ToBuilder (Node a) where - toBuilder n = - case n of - Node2 _ a b -> toBuilder a <> toBuilder b - Node3 _ a b c -> toBuilder a <> toBuilder b <> toBuilder c - -instance ToBuilder a => ToBuilder (Digit a) where - toBuilder d = - case d of - One a -> toBuilder a - Two a b -> toBuilder a <> toBuilder b - Three a b c -> toBuilder a <> toBuilder b <> toBuilder c - Four a b c e -> toBuilder a <> toBuilder b <> toBuilder c <> toBuilder e - diff --git a/src/Codec/Compression/Zlib/HuffmanTree.hs b/src/Codec/Compression/Zlib/HuffmanTree.hs --- a/src/Codec/Compression/Zlib/HuffmanTree.hs +++ b/src/Codec/Compression/Zlib/HuffmanTree.hs @@ -1,56 +1,66 @@ -module Codec.Compression.Zlib.HuffmanTree( - HuffmanTree - , AdvanceResult(..) - , createHuffmanTree - , advanceTree - ) - where +module Codec.Compression.Zlib.HuffmanTree ( + HuffmanTree, + AdvanceResult (..), + createHuffmanTree, + advanceTree, +) where -import Data.Bits(testBit) -import Data.Word(Word8) +import Data.Bits (testBit) +import Data.Word (Word8) -data HuffmanTree a = HuffmanNode (HuffmanTree a) (HuffmanTree a) - | HuffmanValue a - | HuffmanEmpty - deriving (Show) +data HuffmanTree a + = HuffmanNode (HuffmanTree a) (HuffmanTree a) + | HuffmanValue a + | HuffmanEmpty + deriving (Show) -data AdvanceResult a = AdvanceError String - | NewTree (HuffmanTree a) - | Result a +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 :: + 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 + 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 :: + 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 + | 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) + | otherwise -> Right (HuffmanNode newNode HuffmanEmpty) -- - HuffmanValue _ | len == 0 -> - Left "Two values point to the same place!" + 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 _ _ + | 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 @@ -63,11 +73,11 @@ 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 -> + 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!" + HuffmanEmpty -> AdvanceError "Advanced to empty tree!" HuffmanValue y -> Result y - t -> NewTree t + t -> NewTree t {-# INLINE advanceTree #-} diff --git a/src/Codec/Compression/Zlib/Monad.hs b/src/Codec/Compression/Zlib/Monad.hs --- a/src/Codec/Compression/Zlib/Monad.hs +++ b/src/Codec/Compression/Zlib/Monad.hs @@ -1,307 +1,358 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# 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 +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE Rank2Types #-} -import Codec.Compression.Zlib.Adler32(AdlerState, initialAdlerState, - advanceAdler, advanceAdlerBlock, - 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 +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, + advanceAdler, + advanceAdlerBlock, + finalizeAdler, + initialAdlerState, + ) +import Codec.Compression.Zlib.HuffmanTree ( + AdvanceResult (..), + HuffmanTree, + advanceTree, + ) +import Codec.Compression.Zlib.OutputWindow ( + OutputWindow, + addByte, + addChunk, + addOldChunk, + emitExcess, + emptyWindow, + finalizeWindow, + ) +import Control.Exception (Exception) +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 +import Data.Int (Int64) +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word8) +import GHC.ST (ST) +import Prelude.Compat +import Prelude () -data DecompressionState = DecompressionState { - dcsNextBitNo :: !Int - , dcsCurByte :: !Word8 - , dcsAdler32 :: !AdlerState - , dcsInput :: !S.ByteString - , dcsOutput :: !OutputWindow - } +data DecompressionState s = DecompressionState + { dcsNextBitNo :: !Int + , dcsCurByte :: !Word8 + , dcsAdler32 :: !AdlerState + , dcsInput :: !S.ByteString + , dcsOutput :: !(OutputWindow s) + } -instance Show DecompressionState where - show dcs = "DecompressionState" +instance Show (DecompressionState s) where + show dcs = + "DecompressionState" -- ----------------------------------------------------------------------------- -data DecompressionError = HuffmanTreeError String - | FormatError String - | DecompressionError String - | HeaderError String - | ChecksumError String +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 + 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 + HeaderError s -> "Header error: " ++ s + ChecksumError s -> "Checksum error: " ++ s instance Exception DecompressionError -- ----------------------------------------------------------------------------- -newtype DeflateM a = DeflateM { - unDeflateM :: DecompressionState -> - (DecompressionState -> a -> ZlibDecoder) -> - ZlibDecoder +newtype DeflateM s a = DeflateM + { unDeflateM :: + DecompressionState s -> + (DecompressionState s -> a -> ST s (ZlibDecoder s)) -> + ST s (ZlibDecoder s) } -instance Applicative DeflateM where - pure x = DeflateM (\ s k -> k s x) +instance Applicative (DeflateM s) 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) + 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 + m *> n = DeflateM $ \s1 k -> + unDeflateM m s1 $ \s2 _ -> unDeflateM n s2 k {-# INLINE pure #-} {-# INLINE (<*>) #-} {-# INLINE (*>) #-} - -instance Functor DeflateM where +instance Functor (DeflateM s) where fmap f m = DeflateM (\s k -> unDeflateM m s (\s' a -> k s' (f a))) {-# INLINE fmap #-} -instance Monad DeflateM where +instance Monad (DeflateM s) where {-# INLINE return #-} return = pure {-# INLINE (>>=) #-} - m >>= f = DeflateM $ \ s1 k -> - unDeflateM m s1 $ \ s2 a -> unDeflateM (f a) s2 k + 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) +get :: DeflateM s (DecompressionState s) +get = DeflateM (\s k -> k s s) {-# INLINE get #-} -set :: DecompressionState -> DeflateM () -set !s = DeflateM (\ _ k -> k s ()) +set :: DecompressionState s -> DeflateM s () +set !s = DeflateM (\_ k -> k s ()) {-# INLINE set #-} -raise :: DecompressionError -> DeflateM a -raise e = DeflateM (\ _ _ -> DecompError e) +raise :: DecompressionError -> DeflateM s a +raise e = DeflateM (\_ _ -> return (DecompError e)) {-# INLINE raise #-} -initialState :: DecompressionState -initialState = DecompressionState { - dcsNextBitNo = 8 - , dcsCurByte = 0 - , dcsAdler32 = initialAdlerState - , dcsInput = S.empty - , dcsOutput = emptyWindow - } +liftST :: ST s a -> DeflateM s a +liftST action = DeflateM $ \s k -> do + res <- action + k s res -- ----------------------------------------------------------------------------- -data ZlibDecoder = NeedMore (S.ByteString -> ZlibDecoder) - | Chunk L.ByteString ZlibDecoder - | Done - | DecompError DecompressionError +data ZlibDecoder s + = NeedMore (S.ByteString -> ST s (ZlibDecoder s)) + | Chunk S.ByteString (ST s (ZlibDecoder s)) + | Done + | DecompError DecompressionError -runDeflateM :: DeflateM () -> ZlibDecoder -runDeflateM m = unDeflateM m initialState (\ _ _ -> Done) +runDeflateM :: DeflateM s () -> ST s (ZlibDecoder s) +runDeflateM m = do + window <- emptyWindow + let initialState = + DecompressionState + { dcsNextBitNo = 8 + , dcsCurByte = 0 + , dcsAdler32 = initialAdlerState + , dcsInput = S.empty + , dcsOutput = window + } + unDeflateM m initialState (\_ _ -> return Done) {-# INLINE runDeflateM #-} -- ----------------------------------------------------------------------------- -getNextChunk :: DeflateM () -getNextChunk = DeflateM $ \ st k -> NeedMore (loadChunk st k) +getNextChunk :: DeflateM s () +getNextChunk = DeflateM $ \st k -> return (NeedMore (loadChunk st k)) where + loadChunk :: + DecompressionState s -> + (DecompressionState s -> () -> ST s (ZlibDecoder s)) -> + S.ByteString -> + ST s (ZlibDecoder s) loadChunk st k bstr = case S.uncons bstr of - Nothing -> NeedMore (loadChunk st k) + Nothing -> return (NeedMore (loadChunk st k)) Just (nextb, rest) -> - k st { dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest } () + k st{dcsNextBitNo = 0, dcsCurByte = nextb, dcsInput = rest} () -{-# SPECIALIZE nextBits :: Int -> DeflateM Word8 #-} -{-# SPECIALIZE nextBits :: Int -> DeflateM Int #-} -{-# SPECIALIZE nextBits :: Int -> DeflateM Int64 #-} +{-# SPECIALIZE nextBits :: Int -> DeflateM s Word8 #-} +{-# SPECIALIZE nextBits :: Int -> DeflateM s Int #-} +{-# SPECIALIZE nextBits :: Int -> DeflateM s Int64 #-} {-# INLINE nextBits #-} -nextBits :: (Num a, Bits a) => Int -> DeflateM a +nextBits :: (Num a, Bits a) => Int -> DeflateM s 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 #-} +{-# SPECIALIZE nextBits' :: Int -> Int -> Word8 -> DeflateM s Word8 #-} +{-# SPECIALIZE nextBits' :: Int -> Int -> Int -> DeflateM s Int #-} +{-# SPECIALIZE nextBits' :: Int -> Int -> Int64 -> DeflateM s Int64 #-} {-# INLINE nextBits' #-} -nextBits' :: (Num a, Bits a) => Int -> Int -> a -> DeflateM a +nextBits' :: (Num a, Bits a) => Int -> Int -> a -> DeflateM s 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' + | 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 +nextByte :: DeflateM s 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) +nextWord16 :: DeflateM s 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) +nextWord32 :: DeflateM s 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.") +nextBlock :: Integral a => a -> DeflateM s 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) + | 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 +nextCode :: Show a => HuffmanTree a -> DeflateM s 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 } +advanceToByte :: DeflateM s () +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 } +emitByte :: Word8 -> DeflateM s () +emitByte b = do + dcs <- get + output' <- liftST (addByte (dcsOutput dcs) b) + let adler' = advanceAdler (dcsAdler32 dcs) b + set dcs{dcsOutput = output', dcsAdler32 = adler'} {-# INLINE emitByte #-} -emitBlock :: L.ByteString -> DeflateM () -emitBlock b = - do dcs <- get - set dcs { dcsOutput = dcsOutput dcs `addChunk` b - , dcsAdler32 = advanceAdlerBlock (dcsAdler32 dcs) b } +emitBlock :: L.ByteString -> DeflateM s () +emitBlock b = do + dcs <- get + output' <- liftST (addChunk (dcsOutput dcs) b) + let adler' = L.foldlChunks advanceAdlerBlock (dcsAdler32 dcs) b + set dcs{dcsOutput = output', dcsAdler32 = adler'} -emitPastChunk :: Int -> Int64 -> DeflateM () -emitPastChunk dist len = - do dcs <- get - let (output', newChunk) = addOldChunk (dcsOutput dcs) dist len - set dcs { dcsOutput = output' - , dcsAdler32 = advanceAdlerBlock (dcsAdler32 dcs) newChunk } +emitPastChunk :: Int -> Int -> DeflateM s () +emitPastChunk dist len = do + dcs <- get + (output', newChunk) <- liftST (addOldChunk (dcsOutput dcs) dist len) + set + dcs + { dcsOutput = output' + , dcsAdler32 = advanceAdlerBlock (dcsAdler32 dcs) newChunk + } {-# INLINE emitPastChunk #-} -finalAdler :: DeflateM Word32 -finalAdler = (finalizeAdler . dcsAdler32) `fmap` get +finalAdler :: DeflateM s Word32 +finalAdler = (finalizeAdler . dcsAdler32) <$> get -moveWindow :: DeflateM () -moveWindow = - do dcs <- get - case emitExcess (dcsOutput dcs) of - Nothing -> - return () - Just (builtChunks, output') -> - do set dcs{ dcsOutput = output' } - publishLazy builtChunks +moveWindow :: DeflateM s () +moveWindow = do + dcs <- get + possibleExcess <- liftST (emitExcess (dcsOutput dcs)) + case possibleExcess of + Nothing -> + return () + Just (builtChunk, output') -> do + set dcs{dcsOutput = output'} + publish builtChunk -finalize :: DeflateM () -finalize = - do dcs <- get - publishLazy (finalizeWindow (dcsOutput dcs)) +finalize :: DeflateM s () +finalize = do + dcs <- get + lastChunk <- liftST (finalizeWindow (dcsOutput dcs)) + publish lastChunk -{-# INLINE publishLazy #-} -publishLazy :: L.ByteString -> DeflateM () -publishLazy lbstr = DeflateM (\ st k -> Chunk lbstr (k st ())) +{-# INLINE publish #-} +publish :: S.ByteString -> DeflateM s () +publish bstr = DeflateM $ \st k -> + return (Chunk bstr (k st ())) diff --git a/src/Codec/Compression/Zlib/OutputWindow.hs b/src/Codec/Compression/Zlib/OutputWindow.hs --- a/src/Codec/Compression/Zlib/OutputWindow.hs +++ b/src/Codec/Compression/Zlib/OutputWindow.hs @@ -1,65 +1,114 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE UnboxedTuples #-} {-# 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) -import qualified Data.ByteString as S +module Codec.Compression.Zlib.OutputWindow ( + OutputWindow, + emptyWindow, + emitExcess, + finalizeWindow, + addByte, + addChunk, + addOldChunk, +) where + +import Control.Monad (foldM) +import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Codec.Compression.Zlib.FingerTree(FingerTree, empty, (|>), dropTakeCombine, split, measure, toBuilder) -import Data.Int(Int64) -import Data.Semigroup as Sem -import Data.Word(Word8) -import Prelude() -import Prelude.Compat +import qualified Data.ByteString.Short as SBS +import Data.ByteString.Short.Internal (ShortByteString (SBS)) +import qualified Data.Primitive as Prim +import qualified Data.Vector.Primitive as V +import qualified Data.Vector.Primitive.Mutable as MV +import GHC.ST (ST (..)) +import GHC.Word (Word8 (..)) -type WindowType = FingerTree S.ByteString +windowSize :: Int +windowSize = 128 * 1024 -data OutputWindow = OutputWindow { - owWindow :: WindowType - , owRecent :: Builder - } +data OutputWindow s = OutputWindow + { owWindow :: {-# UNPACK #-} !(MV.MVector s Word8) + , owNext :: {-# UNPACK #-} !Int + } -emptyWindow :: OutputWindow -emptyWindow = OutputWindow empty mempty +emptyWindow :: ST s (OutputWindow s) +emptyWindow = do + window <- MV.new windowSize + return (OutputWindow window 0) -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 (toBuilder excessFT) +excessChunkSize :: Int +excessChunkSize = 32768 -finalizeWindow :: OutputWindow -> L.ByteString -finalizeWindow ow = toLazyByteString (toBuilder (owWindow ow) <> owRecent ow) +emitExcess :: OutputWindow s -> ST s (Maybe (S.ByteString, OutputWindow s)) +emitExcess OutputWindow{owWindow = window, owNext = initialOffset} + | initialOffset < excessChunkSize * 2 = return Nothing + | otherwise = do + toEmit <- V.freeze $ MV.slice 0 excessChunkSize window + let excessLength = initialOffset - excessChunkSize + -- Need move as these can overlap! + MV.move (MV.slice 0 excessLength window) (MV.slice excessChunkSize excessLength window) + let ow' = OutputWindow window excessLength + return (Just (SBS.fromShort $ toByteString toEmit, ow')) +finalizeWindow :: OutputWindow s -> ST s S.ByteString +finalizeWindow ow = do + -- safe as we're doing it at the end + res <- V.unsafeFreeze (MV.slice 0 (owNext ow) (owWindow ow)) + pure $ SBS.fromShort $ toByteString res + -- ----------------------------------------------------------------------------- -addByte :: OutputWindow -> Word8 -> OutputWindow -addByte !ow !b = ow{ owRecent = owRecent ow <> word8 b } +addByte :: OutputWindow s -> Word8 -> ST s (OutputWindow s) +addByte !ow !b = do + let offset = owNext ow + MV.write (owWindow ow) offset b + return ow{owNext = offset + 1} -addChunk :: OutputWindow -> L.ByteString -> OutputWindow -addChunk !ow !bs = ow{ owRecent = owRecent ow <> lazyByteString bs } +addChunk :: OutputWindow s -> L.ByteString -> ST s (OutputWindow s) +addChunk !ow !bs = foldM copyChunk ow (L.toChunks bs) -addOldChunk :: OutputWindow -> Int -> Int64 -> (OutputWindow, L.ByteString) -addOldChunk !ow !dist !len = (OutputWindow output (lazyByteString chunk), chunk) +copyChunk :: OutputWindow s -> S.ByteString -> ST s (OutputWindow s) +copyChunk ow sbstr = do + -- safe as we're never going to look at this again + ba <- V.unsafeThaw $ fromByteString $ SBS.toShort sbstr + let offset = owNext ow + len = MV.length ba + MV.copy (MV.slice offset len (owWindow ow)) ba + return ow{owNext = offset + len} + +addOldChunk :: OutputWindow s -> Int -> Int -> ST s (OutputWindow s, S.ByteString) +addOldChunk (OutputWindow window next) dist len = do + -- zlib can ask us to copy an "old" chunk that extends past our current offset. + -- The intention is that we then start copying the "new" data we just copied into + -- place. 'copyChunked' handles this for us. + copyChunked (MV.slice next len window) (MV.slice (next - dist) len window) dist + result <- V.freeze $ MV.slice next len window + return (OutputWindow window (next + len), SBS.fromShort $ toByteString result) + +{- | A copy function that copies the buffers sequentially in chunks no larger than + the stated size. This allows us to handle the insane zlib behaviour. +-} +copyChunked :: MV.MVector s Word8 -> MV.MVector s Word8 -> Int -> ST s () +copyChunked dest src chunkSize = go 0 (MV.length src) where - output = L.foldlChunks (|>) (owWindow ow) (toLazyByteString (owRecent ow)) - dropAmt = measure output - dist - (prev, sme) = split dropAmt output - chunkBase = dropTakeCombine (dropAmt - measure prev) (fromIntegral len) sme - chunkInf = chunkBase `L.append` chunkInf - chunk = L.take len chunkInf + go _ 0 = pure () + go copied toCopy = do + let thisChunkSize = min toCopy chunkSize + MV.copy (MV.slice copied thisChunkSize dest) (MV.slice copied thisChunkSize src) + go (copied + thisChunkSize) (toCopy - thisChunkSize) + +-- TODO: these are a bit questionable. Maybe we can just pass around Vector Word8 in the client code? +fromByteString :: SBS.ShortByteString -> V.Vector Word8 +fromByteString (SBS ba) = + let len = Prim.sizeofByteArray (Prim.ByteArray ba) + sz = Prim.sizeOf (undefined :: Word8) + in V.Vector 0 (len * sz) (Prim.ByteArray ba) + +toByteString :: V.Vector Word8 -> SBS.ShortByteString +toByteString (V.Vector offset len ba) = + let sz = Prim.sizeOf (undefined :: Word8) + !(Prim.ByteArray ba') = Prim.cloneByteArray ba (offset * sz) (len * sz) + in SBS ba' diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -1,18 +1,18 @@ import Codec.Compression.Zlib import Codec.Compression.Zlib.Deflate -import Data.ByteString.Lazy(readFile) +import Data.ByteString.Lazy (readFile) import Data.Char (ord) -import Data.List(last, isPrefixOf) -import Prelude hiding (readFile) +import Data.List (isPrefixOf) import System.FilePath import Test.Tasty import Test.Tasty.HUnit +import Prelude hiding (readFile) -- ----------------------------------------------------------------------------- rfcSimpleTestLengths :: [(Int, Int)] -rfcSimpleTestLengths = [ - (ord 'A', 3) +rfcSimpleTestLengths = + [ (ord 'A', 3) , (ord 'B', 3) , (ord 'C', 3) , (ord 'D', 3) @@ -23,76 +23,103 @@ ] 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 +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]]) + ( [(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 + ( [(fst x, 8, snd x) | x <- zip [0 .. 143] [48 .. 191]] + ++ [(fst x, 9, snd x) | x <- zip [144 .. 255] [400 .. 511]] -- 00110000 through 10111111 + ++ [(fst x, 7, snd x) | x <- zip [256 .. 279] [0 .. 23]] -- 110010000 through 111111111 + ++ [(fst x, 8, snd x) | x <- zip [280 .. 287] [192 .. 199]] -- 0000000 through 0010111 + -- 11000000 through 11000111 + ) -- ----------------------------------------------------------------------------- testCases :: [FilePath] -testCases = [ "randtest1", "randtest2", "randtest3", - "rfctest1", "rfctest2", "rfctest3", - "zerotest1", "zerotest2", "zerotest3" ] +testCases = + [ "randtest1" + , "randtest2" + , "randtest3" + , "rfctest1" + , "rfctest2" + , "rfctest3" + , "zerotest1" + , "zerotest2" + , "zerotest3" + ] buildGoldTestCases :: IO TestTree buildGoldTestCases = - do trees <- mapM buildGoldTest testCases - return (testGroup "Decompression Tests" trees) + 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))) + 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." + 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 - ] + 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 - diff --git a/test/test-cases/bytes-tl.gold b/test/test-cases/bytes-tl.gold deleted file mode 100644 # file too large to diff: test/test-cases/bytes-tl.gold