{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE Rank2Types #-}
module Codec.Compression.Zlib.Monad(
DeflateM
, runDeflateM
, ZlibDecoder(..)
, raise
, DecompressionError(..)
, nextBits
, nextByte
, nextWord16
, nextWord32
, nextBlock
, nextCode
, advanceToByte
, emitByte
, emitBlock
, emitPastChunk
, 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
| 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
| 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 ()))