{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE Rank2Types                 #-}
module Codec.Compression.Zlib.Monad(
         DeflateM
       , runDeflateM
       , ZlibDecoder(..)
       , raise
       , DecompressionError(..)
         -- * Getting data from the input stream.
       , nextBits
       , nextByte
       , nextWord16
       , nextWord32
       , nextBlock
       , nextCode
         -- * Aligning
       , advanceToByte
         -- * Emitting data into the output window
       , emitByte
       , emitBlock
       , emitPastChunk
         -- * Getting and publishing output
       , finalAdler
       , moveWindow
       , finalize
       )
 where

import           Codec.Compression.Zlib.Adler32(AdlerState, initialAdlerState,
                                                advanceAdler, 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
import qualified Data.ByteString.Lazy as L
import           Data.Int(Int64)
import           Data.Typeable(Typeable)
import           Data.Word(Word32, Word16, Word8)
import           Prelude()
import           Prelude.Compat

data DecompressionState = DecompressionState {
       DecompressionState -> Int
dcsNextBitNo     :: !Int
     , DecompressionState -> Word8
dcsCurByte       :: !Word8
     , DecompressionState -> AdlerState
dcsAdler32       :: !AdlerState
     , DecompressionState -> ByteString
dcsInput         :: !S.ByteString
     , DecompressionState -> OutputWindow
dcsOutput        :: !OutputWindow
     }

instance Show DecompressionState where
  show :: DecompressionState -> String
show DecompressionState
dcs = String
"DecompressionState<nextBit=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (DecompressionState -> Int
dcsNextBitNo DecompressionState
dcs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++
             String
"curByte=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show (DecompressionState -> Word8
dcsCurByte DecompressionState
dcs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",inputLen=" String -> ShowS
forall a. [a] -> [a] -> [a]
++
             Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
S.length (DecompressionState -> ByteString
dcsInput DecompressionState
dcs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
">"

-- -----------------------------------------------------------------------------

data DecompressionError = HuffmanTreeError   String
                        | FormatError        String
                        | DecompressionError String
                        | HeaderError        String
                        | ChecksumError      String
  deriving (Typeable, DecompressionError -> DecompressionError -> Bool
(DecompressionError -> DecompressionError -> Bool)
-> (DecompressionError -> DecompressionError -> Bool)
-> Eq DecompressionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecompressionError -> DecompressionError -> Bool
$c/= :: DecompressionError -> DecompressionError -> Bool
== :: DecompressionError -> DecompressionError -> Bool
$c== :: DecompressionError -> DecompressionError -> Bool
Eq)

instance Show DecompressionError where
  show :: DecompressionError -> String
show DecompressionError
x =
    case DecompressionError
x of
      HuffmanTreeError   String
s -> String
"Huffman tree manipulation error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
      FormatError        String
s -> String
"Block format error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
      DecompressionError String
s -> String
"Decompression error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
      HeaderError        String
s -> String
"Header error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
      ChecksumError      String
s -> String
"Checksum error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s

instance Exception DecompressionError

-- -----------------------------------------------------------------------------

newtype DeflateM a = DeflateM {
    DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM :: DecompressionState ->
                  (DecompressionState -> a -> ZlibDecoder) ->
                  ZlibDecoder
  }

instance Applicative DeflateM where
  pure :: a -> DeflateM a
pure  a
x = (DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM (\ DecompressionState
s DecompressionState -> a -> ZlibDecoder
k -> DecompressionState -> a -> ZlibDecoder
k DecompressionState
s a
x)

  DeflateM (a -> b)
f <*> :: DeflateM (a -> b) -> DeflateM a -> DeflateM b
<*> DeflateM a
x = (DecompressionState
 -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM ((DecompressionState
  -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
 -> DeflateM b)
-> (DecompressionState
    -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s1 DecompressionState -> b -> ZlibDecoder
k ->
     DeflateM (a -> b)
-> DecompressionState
-> (DecompressionState -> (a -> b) -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM (a -> b)
f DecompressionState
s1 ((DecompressionState -> (a -> b) -> ZlibDecoder) -> ZlibDecoder)
-> (DecompressionState -> (a -> b) -> ZlibDecoder) -> ZlibDecoder
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s2 a -> b
g ->
     DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM a
x DecompressionState
s2 ((DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s3 a
y -> DecompressionState -> b -> ZlibDecoder
k DecompressionState
s3 (a -> b
g a
y)

  DeflateM a
m *> :: DeflateM a -> DeflateM b -> DeflateM b
*> DeflateM b
n = (DecompressionState
 -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM ((DecompressionState
  -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
 -> DeflateM b)
-> (DecompressionState
    -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s1 DecompressionState -> b -> ZlibDecoder
k ->
    DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM a
m DecompressionState
s1 ((DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s2 a
_ -> DeflateM b
-> DecompressionState
-> (DecompressionState -> b -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM b
n DecompressionState
s2 DecompressionState -> b -> ZlibDecoder
k

  {-# INLINE pure #-}
  {-# INLINE (<*>) #-}
  {-# INLINE (*>) #-}


instance Functor DeflateM where
  fmap :: (a -> b) -> DeflateM a -> DeflateM b
fmap a -> b
f DeflateM a
m = (DecompressionState
 -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM (\DecompressionState
s DecompressionState -> b -> ZlibDecoder
k -> DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM a
m DecompressionState
s (\DecompressionState
s' a
a -> DecompressionState -> b -> ZlibDecoder
k DecompressionState
s' (a -> b
f a
a)))
  {-# INLINE fmap #-}

instance Monad DeflateM where
  {-# INLINE return #-}
  return :: a -> DeflateM a
return = a -> DeflateM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  {-# INLINE (>>=) #-}
  DeflateM a
m >>= :: DeflateM a -> (a -> DeflateM b) -> DeflateM b
>>= a -> DeflateM b
f = (DecompressionState
 -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM ((DecompressionState
  -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
 -> DeflateM b)
-> (DecompressionState
    -> (DecompressionState -> b -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM b
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s1 DecompressionState -> b -> ZlibDecoder
k ->
     DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM a
m DecompressionState
s1 ((DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
s2 a
a -> DeflateM b
-> DecompressionState
-> (DecompressionState -> b -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM (a -> DeflateM b
f a
a) DecompressionState
s2 DecompressionState -> b -> ZlibDecoder
k

  >> :: DeflateM a -> DeflateM b -> DeflateM b
(>>) = DeflateM a -> DeflateM b -> DeflateM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  {-# INLINE (>>) #-}

get :: DeflateM DecompressionState
get :: DeflateM DecompressionState
get = (DecompressionState
 -> (DecompressionState -> DecompressionState -> ZlibDecoder)
 -> ZlibDecoder)
-> DeflateM DecompressionState
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM (\ DecompressionState
s DecompressionState -> DecompressionState -> ZlibDecoder
k -> DecompressionState -> DecompressionState -> ZlibDecoder
k DecompressionState
s DecompressionState
s)
{-# INLINE get #-}

set :: DecompressionState -> DeflateM ()
set :: DecompressionState -> DeflateM ()
set !DecompressionState
s = (DecompressionState
 -> (DecompressionState -> () -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM ()
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM (\ DecompressionState
_ DecompressionState -> () -> ZlibDecoder
k -> DecompressionState -> () -> ZlibDecoder
k DecompressionState
s ())
{-# INLINE set #-}

raise :: DecompressionError -> DeflateM a
raise :: DecompressionError -> DeflateM a
raise DecompressionError
e = (DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM (\ DecompressionState
_ DecompressionState -> a -> ZlibDecoder
_ -> DecompressionError -> ZlibDecoder
DecompError DecompressionError
e)
{-# INLINE raise #-}

initialState :: DecompressionState
initialState :: DecompressionState
initialState = DecompressionState :: Int
-> Word8
-> AdlerState
-> ByteString
-> OutputWindow
-> DecompressionState
DecompressionState {
    dcsNextBitNo :: Int
dcsNextBitNo = Int
8
  , dcsCurByte :: Word8
dcsCurByte   = Word8
0
  , dcsAdler32 :: AdlerState
dcsAdler32   = AdlerState
initialAdlerState
  , dcsInput :: ByteString
dcsInput     = ByteString
S.empty
  , dcsOutput :: OutputWindow
dcsOutput    = OutputWindow
emptyWindow
  }

-- -----------------------------------------------------------------------------

data ZlibDecoder = NeedMore (S.ByteString -> ZlibDecoder)
                 | Chunk L.ByteString ZlibDecoder
                 | Done
                 | DecompError DecompressionError

runDeflateM :: DeflateM () -> ZlibDecoder
runDeflateM :: DeflateM () -> ZlibDecoder
runDeflateM DeflateM ()
m = DeflateM ()
-> DecompressionState
-> (DecompressionState -> () -> ZlibDecoder)
-> ZlibDecoder
forall a.
DeflateM a
-> DecompressionState
-> (DecompressionState -> a -> ZlibDecoder)
-> ZlibDecoder
unDeflateM DeflateM ()
m DecompressionState
initialState (\ DecompressionState
_ ()
_ -> ZlibDecoder
Done)
{-# INLINE runDeflateM #-}

-- -----------------------------------------------------------------------------

getNextChunk :: DeflateM ()
getNextChunk :: DeflateM ()
getNextChunk = (DecompressionState
 -> (DecompressionState -> () -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM ()
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM ((DecompressionState
  -> (DecompressionState -> () -> ZlibDecoder) -> ZlibDecoder)
 -> DeflateM ())
-> (DecompressionState
    -> (DecompressionState -> () -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM ()
forall a b. (a -> b) -> a -> b
$ \ DecompressionState
st DecompressionState -> () -> ZlibDecoder
k -> (ByteString -> ZlibDecoder) -> ZlibDecoder
NeedMore (DecompressionState
-> (DecompressionState -> () -> ZlibDecoder)
-> ByteString
-> ZlibDecoder
loadChunk DecompressionState
st DecompressionState -> () -> ZlibDecoder
k)
 where
  loadChunk :: DecompressionState
-> (DecompressionState -> () -> ZlibDecoder)
-> ByteString
-> ZlibDecoder
loadChunk DecompressionState
st DecompressionState -> () -> ZlibDecoder
k ByteString
bstr =
    case ByteString -> Maybe (Word8, ByteString)
S.uncons ByteString
bstr of
      Maybe (Word8, ByteString)
Nothing -> (ByteString -> ZlibDecoder) -> ZlibDecoder
NeedMore (DecompressionState
-> (DecompressionState -> () -> ZlibDecoder)
-> ByteString
-> ZlibDecoder
loadChunk DecompressionState
st DecompressionState -> () -> ZlibDecoder
k)
      Just (Word8
nextb, ByteString
rest) ->
         DecompressionState -> () -> ZlibDecoder
k DecompressionState
st { dcsNextBitNo :: Int
dcsNextBitNo = Int
0, dcsCurByte :: Word8
dcsCurByte = Word8
nextb, dcsInput :: ByteString
dcsInput = ByteString
rest } ()

{-# SPECIALIZE nextBits :: Int -> DeflateM Word8 #-}
{-# SPECIALIZE nextBits :: Int -> DeflateM Int   #-}
{-# SPECIALIZE nextBits :: Int -> DeflateM Int64 #-}
{-# INLINE nextBits #-}
nextBits :: (Num a, Bits a) => Int -> DeflateM a
nextBits :: Int -> DeflateM a
nextBits Int
x = Int -> Int -> a -> DeflateM a
forall a. (Num a, Bits a) => Int -> Int -> a -> DeflateM a
nextBits' Int
x Int
0 a
0

{-# SPECIALIZE nextBits' :: Int -> Int -> Word8 -> DeflateM Word8 #-}
{-# SPECIALIZE nextBits' :: Int -> Int -> Int   -> DeflateM Int   #-}
{-# SPECIALIZE nextBits' :: Int -> Int -> Int64 -> DeflateM Int64 #-}
{-# INLINE nextBits' #-}
nextBits' :: (Num a, Bits a) => Int -> Int -> a -> DeflateM a
nextBits' :: Int -> Int -> a -> DeflateM a
nextBits' !Int
x' !Int
shiftNum !a
acc
  | Int
x' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0       = a -> DeflateM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
acc
  | Bool
otherwise     =
      do DecompressionState
dcs <- DeflateM DecompressionState
get
         case DecompressionState -> Int
dcsNextBitNo DecompressionState
dcs of
           Int
8 -> case ByteString -> Maybe (Word8, ByteString)
S.uncons (DecompressionState -> ByteString
dcsInput DecompressionState
dcs) of
                  Maybe (Word8, ByteString)
Nothing ->
                    do DeflateM ()
getNextChunk 
                       Int -> Int -> a -> DeflateM a
forall a. (Num a, Bits a) => Int -> Int -> a -> DeflateM a
nextBits' Int
x' Int
shiftNum a
acc
                  Just (Word8
nextb, ByteString
rest) ->
                    do DecompressionState -> DeflateM ()
set DecompressionState
dcs{dcsNextBitNo :: Int
dcsNextBitNo=Int
0,dcsCurByte :: Word8
dcsCurByte=Word8
nextb,dcsInput :: ByteString
dcsInput=ByteString
rest}
                       Int -> Int -> a -> DeflateM a
forall a. (Num a, Bits a) => Int -> Int -> a -> DeflateM a
nextBits' Int
x' Int
shiftNum a
acc
           Int
nextBitNo ->
             do let !myBits :: Int
myBits = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x' (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nextBitNo)
                    !base :: Word8
base   = DecompressionState -> Word8
dcsCurByte DecompressionState
dcs Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
nextBitNo
                    !mask :: Word8
mask   = Word8 -> Word8
forall a. Bits a => a -> a
complement (Word8
0xFF Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
myBits)
                    !res :: a
res    = Word8 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
base Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask)
                    !acc' :: a
acc'   = a
acc a -> a -> a
forall a. Bits a => a -> a -> a
.|. (a
res a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
shiftNum)
                DecompressionState -> DeflateM ()
set DecompressionState
dcs { dcsNextBitNo :: Int
dcsNextBitNo=Int
nextBitNo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
myBits }
                Int -> Int -> a -> DeflateM a
forall a. (Num a, Bits a) => Int -> Int -> a -> DeflateM a
nextBits' (Int
x' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
myBits) (Int
shiftNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
myBits) a
acc'

nextByte :: DeflateM Word8
nextByte :: DeflateM Word8
nextByte =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     if | DecompressionState -> Int
dcsNextBitNo DecompressionState
dcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> do DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsNextBitNo :: Int
dcsNextBitNo = Int
8 }
                                      Word8 -> DeflateM Word8
forall (m :: * -> *) a. Monad m => a -> m a
return (DecompressionState -> Word8
dcsCurByte DecompressionState
dcs)
        | DecompressionState -> Int
dcsNextBitNo DecompressionState
dcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8 -> Int -> DeflateM Word8
forall a. (Num a, Bits a) => Int -> DeflateM a
nextBits Int
8 -- we're not aligned. sigh.
        | Bool
otherwise             -> case ByteString -> Maybe (Word8, ByteString)
S.uncons (DecompressionState -> ByteString
dcsInput DecompressionState
dcs) of
                                     Maybe (Word8, ByteString)
Nothing -> DeflateM ()
getNextChunk DeflateM () -> DeflateM Word8 -> DeflateM Word8
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> DeflateM Word8
nextByte
                                     Just (Word8
nextb, ByteString
rest) ->
                                       do DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsNextBitNo :: Int
dcsNextBitNo = Int
8,
                                                   dcsCurByte :: Word8
dcsCurByte   = Word8
nextb,
                                                   dcsInput :: ByteString
dcsInput     = ByteString
rest }
                                          Word8 -> DeflateM Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
nextb

nextWord16 :: DeflateM Word16
nextWord16 :: DeflateM Word16
nextWord16 =
  do Word16
low  <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16) -> DeflateM Word8 -> DeflateM Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM Word8
nextByte
     Word16
high <- Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word16) -> DeflateM Word8 -> DeflateM Word16
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM Word8
nextByte
     Word16 -> DeflateM Word16
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word16
high Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
low)

nextWord32 :: DeflateM Word32
nextWord32 :: DeflateM Word32
nextWord32 =
  do Word32
a <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> DeflateM Word8 -> DeflateM Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM Word8
nextByte
     Word32
b <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> DeflateM Word8 -> DeflateM Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM Word8
nextByte
     Word32
c <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> DeflateM Word8 -> DeflateM Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM Word8
nextByte
     Word32
d <- Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> DeflateM Word8 -> DeflateM Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM Word8
nextByte
     Word32 -> DeflateM Word32
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word32
a Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
b Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
c Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
d)

nextBlock :: Integral a => a -> DeflateM L.ByteString
nextBlock :: a -> DeflateM ByteString
nextBlock a
amt =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     if | DecompressionState -> Int
dcsNextBitNo DecompressionState
dcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
            do let startByte :: Word8
startByte = DecompressionState -> Word8
dcsCurByte DecompressionState
dcs
               DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsNextBitNo :: Int
dcsNextBitNo = Int
8 }
               ByteString
rest <- a -> DeflateM ByteString
forall a. Integral a => a -> DeflateM ByteString
nextBlock (a
amt a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
               ByteString -> DeflateM ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> ByteString -> ByteString
L.cons Word8
startByte ByteString
rest)
        | DecompressionState -> Int
dcsNextBitNo DecompressionState
dcs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 ->
            Int -> ByteString -> DeflateM ByteString
getBlock (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
amt) (DecompressionState -> ByteString
dcsInput DecompressionState
dcs)
        | Bool
otherwise             ->
            DecompressionError -> DeflateM ByteString
forall a. DecompressionError -> DeflateM a
raise (String -> DecompressionError
FormatError String
"Can't get a block on a non-byte boundary.")
 where
  getBlock :: Int -> ByteString -> DeflateM ByteString
getBlock Int
len ByteString
bstr
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int
S.length ByteString
bstr = do let (ByteString
mine, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
S.splitAt Int
len ByteString
bstr
                               DecompressionState
dcs <- DeflateM DecompressionState
get
                               DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsNextBitNo :: Int
dcsNextBitNo = Int
8, dcsInput :: ByteString
dcsInput = ByteString
rest }
                               ByteString -> DeflateM ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
L.fromStrict ByteString
mine)
    | ByteString -> Bool
S.null ByteString
bstr         = do DeflateM ()
getNextChunk
                               DecompressionState
dcs <- DeflateM DecompressionState
get
                               let byte1 :: Word8
byte1 = DecompressionState -> Word8
dcsCurByte DecompressionState
dcs
                               ByteString
rest <- Int -> ByteString -> DeflateM ByteString
getBlock (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (DecompressionState -> ByteString
dcsInput DecompressionState
dcs)
                               ByteString -> DeflateM ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> ByteString -> ByteString
L.cons Word8
byte1 ByteString
rest)
    | Bool
otherwise           = do ByteString
rest <- Int -> ByteString -> DeflateM ByteString
getBlock (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
S.length ByteString
bstr) ByteString
S.empty
                               ByteString -> DeflateM ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
L.fromStrict ByteString
bstr ByteString -> ByteString -> ByteString
`L.append` ByteString
rest)

nextCode :: Show a => HuffmanTree a -> DeflateM a
nextCode :: HuffmanTree a -> DeflateM a
nextCode HuffmanTree a
tree =
  do Word8
b <- Int -> DeflateM Word8
forall a. (Num a, Bits a) => Int -> DeflateM a
nextBits Int
1
     case Word8 -> HuffmanTree a -> AdvanceResult a
forall a. Word8 -> HuffmanTree a -> AdvanceResult a
advanceTree Word8
b HuffmanTree a
tree of
       AdvanceError String
str -> DecompressionError -> DeflateM a
forall a. DecompressionError -> DeflateM a
raise (String -> DecompressionError
HuffmanTreeError String
str)
       NewTree HuffmanTree a
tree'    -> HuffmanTree a -> DeflateM a
forall a. Show a => HuffmanTree a -> DeflateM a
nextCode HuffmanTree a
tree'
       Result a
x         -> a -> DeflateM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
{-# INLINE nextCode #-}

advanceToByte :: DeflateM ()
advanceToByte :: DeflateM ()
advanceToByte =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsNextBitNo :: Int
dcsNextBitNo = Int
8 }

emitByte :: Word8 -> DeflateM ()
emitByte :: Word8 -> DeflateM ()
emitByte Word8
b =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsOutput :: OutputWindow
dcsOutput  = DecompressionState -> OutputWindow
dcsOutput DecompressionState
dcs OutputWindow -> Word8 -> OutputWindow
`addByte` Word8
b
            , dcsAdler32 :: AdlerState
dcsAdler32 = AdlerState -> Word8 -> AdlerState
advanceAdler (DecompressionState -> AdlerState
dcsAdler32 DecompressionState
dcs) Word8
b }
{-# INLINE emitByte #-}

emitBlock :: L.ByteString -> DeflateM ()
emitBlock :: ByteString -> DeflateM ()
emitBlock ByteString
b =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     DecompressionState -> DeflateM ()
set DecompressionState
dcs { dcsOutput :: OutputWindow
dcsOutput  = DecompressionState -> OutputWindow
dcsOutput DecompressionState
dcs OutputWindow -> ByteString -> OutputWindow
`addChunk` ByteString
b
             , dcsAdler32 :: AdlerState
dcsAdler32 = AdlerState -> ByteString -> AdlerState
advanceAdlerBlock (DecompressionState -> AdlerState
dcsAdler32 DecompressionState
dcs) ByteString
b }

emitPastChunk :: Int -> Int64 -> DeflateM ()
emitPastChunk :: Int -> Int64 -> DeflateM ()
emitPastChunk Int
dist Int64
len =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     let (OutputWindow
output', ByteString
newChunk) = OutputWindow -> Int -> Int64 -> (OutputWindow, ByteString)
addOldChunk (DecompressionState -> OutputWindow
dcsOutput DecompressionState
dcs) Int
dist Int64
len
     DecompressionState -> DeflateM ()
set DecompressionState
dcs { dcsOutput :: OutputWindow
dcsOutput = OutputWindow
output'
             , dcsAdler32 :: AdlerState
dcsAdler32 = AdlerState -> ByteString -> AdlerState
advanceAdlerBlock (DecompressionState -> AdlerState
dcsAdler32 DecompressionState
dcs) ByteString
newChunk }
{-# INLINE emitPastChunk #-}

finalAdler :: DeflateM Word32
finalAdler :: DeflateM Word32
finalAdler = (AdlerState -> Word32
finalizeAdler (AdlerState -> Word32)
-> (DecompressionState -> AdlerState)
-> DecompressionState
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecompressionState -> AdlerState
dcsAdler32) (DecompressionState -> Word32)
-> DeflateM DecompressionState -> DeflateM Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DeflateM DecompressionState
get

moveWindow :: DeflateM ()
moveWindow :: DeflateM ()
moveWindow =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     case OutputWindow -> Maybe (ByteString, OutputWindow)
emitExcess (DecompressionState -> OutputWindow
dcsOutput DecompressionState
dcs) of
       Maybe (ByteString, OutputWindow)
Nothing ->
         () -> DeflateM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       Just (ByteString
builtChunks, OutputWindow
output') ->
         do DecompressionState -> DeflateM ()
set DecompressionState
dcs{ dcsOutput :: OutputWindow
dcsOutput = OutputWindow
output' }
            ByteString -> DeflateM ()
publishLazy ByteString
builtChunks

finalize :: DeflateM ()
finalize :: DeflateM ()
finalize =
  do DecompressionState
dcs <- DeflateM DecompressionState
get
     ByteString -> DeflateM ()
publishLazy (OutputWindow -> ByteString
finalizeWindow (DecompressionState -> OutputWindow
dcsOutput DecompressionState
dcs))

{-# INLINE publishLazy #-}
publishLazy :: L.ByteString -> DeflateM ()
publishLazy :: ByteString -> DeflateM ()
publishLazy ByteString
lbstr = (DecompressionState
 -> (DecompressionState -> () -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM ()
forall a.
(DecompressionState
 -> (DecompressionState -> a -> ZlibDecoder) -> ZlibDecoder)
-> DeflateM a
DeflateM (\ DecompressionState
st DecompressionState -> () -> ZlibDecoder
k -> ByteString -> ZlibDecoder -> ZlibDecoder
Chunk ByteString
lbstr (DecompressionState -> () -> ZlibDecoder
k DecompressionState
st ()))