pure-zlib 0.6.8 → 0.8.0

raw patch · 13 files changed

+959/−1384 lines, 13 filesdep +ghc-primdep +primitivedep +vectorsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-prim, primitive, vector, zlib

API changes (from Hackage documentation)

Files

• Benchmark.hs +80/−32
• Deflate.hs +43/−35
• Setup.hs +1/−0
• pure-zlib.cabal +18/−5
• src/Codec/Compression/Zlib.hs +58/−47
• src/Codec/Compression/Zlib/Adler32.hs +24/−23
• src/Codec/Compression/Zlib/Deflate.hs +239/−203
• src/Codec/Compression/Zlib/FingerTree.hs +0/−680
• src/Codec/Compression/Zlib/HuffmanTree.hs +48/−38
• src/Codec/Compression/Zlib/Monad.hs +277/−226
• src/Codec/Compression/Zlib/OutputWindow.hs +98/−49
• test/Test.hs +73/−46
• test/test-cases/bytes-tl.gold too large to diff

@@ -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)

@@ -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

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -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

@@ -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

@@ -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

@@ -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]--

@@ -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.---    <http://staff.city.ac.uk/~ross/papers/FingerTree.html>------ 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- 

@@ -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 #-}

@@ -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<nextBit=" ++ show (dcsNextBitNo dcs) ++ "," ++-             "curByte=" ++ show (dcsCurByte dcs) ++ ",inputLen=" ++-             show (S.length (dcsInput dcs)) ++ ">"+instance Show (DecompressionState s) where+  show dcs =+    "DecompressionState<nextBit=" ++ show (dcsNextBitNo dcs) ++ ","+      ++ "curByte="+      ++ show (dcsCurByte dcs)+      ++ ",inputLen="+      ++ show (S.length (dcsInput dcs))+      ++ ">"  -- ----------------------------------------------------------------------------- -data DecompressionError = HuffmanTreeError   String-                        | FormatError        String-                        | DecompressionError String-                        | HeaderError        String-                        | ChecksumError      String+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 ()))

@@ -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'

@@ -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-

file too large to diff