{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
module Codec.Picture.BitWriter( BoolReader
, emptyBoolState
, BoolState
, byteAlignJpg
, getNextBitsLSBFirst
, getNextBitsMSBFirst
, getNextBitJpg
, getNextIntJpg
, setDecodedString
, setDecodedStringMSB
, setDecodedStringJpg
, runBoolReader
, BoolWriteStateRef
, newWriteStateRef
, finalizeBoolWriter
, finalizeBoolWriterGif
, writeBits'
, writeBitsGif
, initBoolState
, initBoolStateJpg
, execBoolReader
, runBoolReaderWith
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( (<*>), (<$>) )
#endif
import Data.STRef
import Control.Monad( when )
import Control.Monad.ST( ST )
import qualified Control.Monad.Trans.State.Strict as S
import Data.Int ( Int32 )
import Data.Word( Word8, Word32 )
import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL )
import Codec.Picture.VectorByteConversion( blitVector )
import qualified Data.Vector.Storable.Mutable as M
import qualified Data.Vector.Storable as VS
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
data BoolState = BoolState {-# UNPACK #-} !Int
{-# UNPACK #-} !Word8
!B.ByteString
emptyBoolState :: BoolState
emptyBoolState :: BoolState
emptyBoolState = Int -> Word8 -> ByteString -> BoolState
BoolState (-Int
1) Word8
0 ByteString
B.empty
type BoolReader s a = S.StateT BoolState (ST s) a
runBoolReader :: BoolReader s a -> ST s a
runBoolReader :: forall s a. BoolReader s a -> ST s a
runBoolReader BoolReader s a
action = BoolReader s a -> BoolState -> ST s a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
S.evalStateT BoolReader s a
action (BoolState -> ST s a) -> BoolState -> ST s a
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
0 Word8
0 ByteString
B.empty
runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState)
runBoolReaderWith :: forall s a. BoolState -> BoolReader s a -> ST s (a, BoolState)
runBoolReaderWith BoolState
st BoolReader s a
action = BoolReader s a -> BoolState -> ST s (a, BoolState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
S.runStateT BoolReader s a
action BoolState
st
execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState
execBoolReader :: forall s a. BoolState -> BoolReader s a -> ST s BoolState
execBoolReader BoolState
st BoolReader s a
reader = BoolReader s a -> BoolState -> ST s BoolState
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
S.execStateT BoolReader s a
reader BoolState
st
initBoolState :: B.ByteString -> BoolState
initBoolState :: ByteString -> BoolState
initBoolState ByteString
str = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> Int -> Word8 -> ByteString -> BoolState
BoolState Int
0 Word8
0 ByteString
B.empty
Just (Word8
v, ByteString
rest) -> Int -> Word8 -> ByteString -> BoolState
BoolState Int
0 Word8
v ByteString
rest
initBoolStateJpg :: B.ByteString -> BoolState
initBoolStateJpg :: ByteString -> BoolState
initBoolStateJpg ByteString
str =
case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> Int -> Word8 -> ByteString -> BoolState
BoolState Int
0 Word8
0 ByteString
B.empty
Just (Word8
0xFF, ByteString
rest) -> case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
rest of
Maybe (Word8, ByteString)
Nothing -> Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
0 ByteString
B.empty
Just (Word8
0x00, ByteString
afterMarker) -> Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
0xFF ByteString
afterMarker
Just (Word8
_ , ByteString
afterMarker) -> ByteString -> BoolState
initBoolStateJpg ByteString
afterMarker
Just (Word8
v, ByteString
rest) -> Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
v ByteString
rest
setDecodedString :: B.ByteString -> BoolReader s ()
setDecodedString :: forall s. ByteString -> BoolReader s ()
setDecodedString ByteString
str = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
0 Word8
0 ByteString
B.empty
Just (Word8
v, ByteString
rest) -> BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
0 Word8
v ByteString
rest
byteAlignJpg :: BoolReader s ()
byteAlignJpg :: forall s. BoolReader s ()
byteAlignJpg = do
BoolState idx _ chain <- StateT BoolState (ST s) BoolState
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
when (idx /= 7) (setDecodedStringJpg chain)
getNextBitJpg :: BoolReader s Bool
{-# INLINE getNextBitJpg #-}
getNextBitJpg :: forall s. BoolReader s Bool
getNextBitJpg = do
BoolState idx v chain <- StateT BoolState (ST s) BoolState
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
let val = (Word8
v Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
1 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
idx)) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0
if idx == 0
then setDecodedStringJpg chain
else S.put $ BoolState (idx - 1) v chain
return val
getNextIntJpg :: Int -> BoolReader s Int32
{-# INLINE getNextIntJpg #-}
getNextIntJpg :: forall s. Int -> BoolReader s Int32
getNextIntJpg = Int32 -> Int -> StateT BoolState (ST s) Int32
forall {t} {s}.
(Bits t, Num t) =>
t -> Int -> StateT BoolState (ST s) t
go Int32
0 where
go :: t -> Int -> StateT BoolState (ST s) t
go !t
acc !Int
0 = t -> StateT BoolState (ST s) t
forall a. a -> StateT BoolState (ST s) a
forall (m :: * -> *) a. Monad m => a -> m a
return t
acc
go !t
acc !Int
n = do
BoolState idx v chain <- StateT BoolState (ST s) BoolState
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
let !leftBits = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx
if n >= leftBits then do
setDecodedStringJpg chain
let !remaining = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftBits
!mask = (t
1 t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
leftBits) t -> t -> t
forall a. Num a => a -> a -> a
- t
1
!finalV = Word8 -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v t -> t -> t
forall a. Bits a => a -> a -> a
.&. t
mask
!theseBits = t
finalV t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
remaining
go (acc .|. theseBits) remaining
else do
let !remaining = Int
leftBits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
!mask = (t
1 t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
n) t -> t -> t
forall a. Num a => a -> a -> a
- t
1
!finalV = Word8 -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
remaining
S.put $ BoolState (fromIntegral remaining - 1) v chain
return $ (finalV .&. mask) .|. acc
setDecodedStringMSB :: B.ByteString -> BoolReader s ()
setDecodedStringMSB :: forall s. ByteString -> BoolReader s ()
setDecodedStringMSB ByteString
str = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
8 Word8
0 ByteString
B.empty
Just (Word8
v, ByteString
rest) -> BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
8 Word8
v ByteString
rest
{-# INLINE getNextBitsMSBFirst #-}
getNextBitsMSBFirst :: Int -> BoolReader s Word32
getNextBitsMSBFirst :: forall s. Int -> BoolReader s Word32
getNextBitsMSBFirst Int
requested = Word32 -> Int -> BoolReader s Word32
forall s. Word32 -> Int -> BoolReader s Word32
go Word32
0 Int
requested where
go :: Word32 -> Int -> BoolReader s Word32
go :: forall s. Word32 -> Int -> BoolReader s Word32
go !Word32
acc !Int
0 = Word32 -> StateT BoolState (ST s) Word32
forall a. a -> StateT BoolState (ST s) a
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
acc
go !Word32
acc !Int
n = do
BoolState idx v chain <- StateT BoolState (ST s) BoolState
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
let !leftBits = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx
if n >= leftBits then do
setDecodedStringMSB chain
let !theseBits = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftBits)
go (acc .|. theseBits) (n - leftBits)
else do
let !remaining = Int
leftBits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n
!mask = (Word8
1 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
remaining) Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
1
S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain
return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc
{-# INLINE getNextBitsLSBFirst #-}
getNextBitsLSBFirst :: Int -> BoolReader s Word32
getNextBitsLSBFirst :: forall s. Int -> BoolReader s Word32
getNextBitsLSBFirst Int
count = Word32 -> Int -> StateT BoolState (ST s) Word32
forall {t} {s}.
(Bits t, Num t) =>
t -> Int -> StateT BoolState (ST s) t
aux Word32
0 Int
count
where aux :: t -> Int -> StateT BoolState (ST s) t
aux t
acc Int
0 = t -> StateT BoolState (ST s) t
forall a. a -> StateT BoolState (ST s) a
forall (m :: * -> *) a. Monad m => a -> m a
return t
acc
aux t
acc Int
n = do
bit <- BoolReader s Bool
forall s. BoolReader s Bool
getNextBit
let nextVal | Bool
bit = t
acc t -> t -> t
forall a. Bits a => a -> a -> a
.|. (t
1 t -> Int -> t
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n))
| Bool
otherwise = t
acc
aux nextVal (n - 1)
{-# INLINE getNextBit #-}
getNextBit :: BoolReader s Bool
getNextBit :: forall s. BoolReader s Bool
getNextBit = do
BoolState idx v chain <- StateT BoolState (ST s) BoolState
forall (m :: * -> *) s. Monad m => StateT s m s
S.get
let val = (Word8
v Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. (Word8
1 Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
idx)) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0
if idx == 7
then setDecodedString chain
else S.put $ BoolState (idx + 1) v chain
return val
setDecodedStringJpg :: B.ByteString -> BoolReader s ()
setDecodedStringJpg :: forall s. ByteString -> BoolReader s ()
setDecodedStringJpg ByteString
str = case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
0 ByteString
B.empty
Just (Word8
0xFF, ByteString
rest) -> case ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
rest of
Maybe (Word8, ByteString)
Nothing -> BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
0 ByteString
B.empty
Just (Word8
0x00, ByteString
afterMarker) ->
BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
0xFF ByteString
afterMarker
Just (Word8
_ , ByteString
afterMarker) -> ByteString -> BoolReader s ()
forall s. ByteString -> BoolReader s ()
setDecodedStringJpg ByteString
afterMarker
Just (Word8
v, ByteString
rest) ->
BoolState -> BoolReader s ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
S.put (BoolState -> BoolReader s ()) -> BoolState -> BoolReader s ()
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString -> BoolState
BoolState Int
7 Word8
v ByteString
rest
defaultBufferSize :: Int
defaultBufferSize :: Int
defaultBufferSize = Int
256 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024
data BoolWriteStateRef s = BoolWriteStateRef
{ forall s. BoolWriteStateRef s -> STRef s (MVector s Word8)
bwsCurrBuffer :: STRef s (M.MVector s Word8)
, forall s. BoolWriteStateRef s -> STRef s [ByteString]
bwsBufferList :: STRef s [B.ByteString]
, forall s. BoolWriteStateRef s -> STRef s Int
bwsWrittenWords :: STRef s Int
, forall s. BoolWriteStateRef s -> STRef s Word8
bwsBitAcc :: STRef s Word8
, forall s. BoolWriteStateRef s -> STRef s Int
bwsBitReaded :: STRef s Int
}
newWriteStateRef :: ST s (BoolWriteStateRef s)
newWriteStateRef :: forall s. ST s (BoolWriteStateRef s)
newWriteStateRef = do
origMv <- Int -> ST s (MVector (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Storable a) =>
Int -> m (MVector (PrimState m) a)
M.new Int
defaultBufferSize
BoolWriteStateRef <$> newSTRef origMv
<*> newSTRef []
<*> newSTRef 0
<*> newSTRef 0
<*> newSTRef 0
finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString
finalizeBoolWriter :: forall s. BoolWriteStateRef s -> ST s ByteString
finalizeBoolWriter BoolWriteStateRef s
st = do
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
flushLeftBits' BoolWriteStateRef s
st
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
forceBufferFlushing' BoolWriteStateRef s
st
[ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> ST s [ByteString] -> ST s ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STRef s [ByteString] -> ST s [ByteString]
forall s a. STRef s a -> ST s a
readSTRef (BoolWriteStateRef s -> STRef s [ByteString]
forall s. BoolWriteStateRef s -> STRef s [ByteString]
bwsBufferList BoolWriteStateRef s
st)
forceBufferFlushing' :: BoolWriteStateRef s -> ST s ()
forceBufferFlushing' :: forall s. BoolWriteStateRef s -> ST s ()
forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer :: forall s. BoolWriteStateRef s -> STRef s (MVector s Word8)
bwsCurrBuffer = STRef s (MVector s Word8)
vecRef
, bwsWrittenWords :: forall s. BoolWriteStateRef s -> STRef s Int
bwsWrittenWords = STRef s Int
countRef
, bwsBufferList :: forall s. BoolWriteStateRef s -> STRef s [ByteString]
bwsBufferList = STRef s [ByteString]
lstRef
}) = do
vec <- STRef s (MVector s Word8) -> ST s (MVector s Word8)
forall s a. STRef s a -> ST s a
readSTRef STRef s (MVector s Word8)
vecRef
count <- readSTRef countRef
lst <- readSTRef lstRef
nmv <- M.new defaultBufferSize
str <- byteStringFromVector vec count
writeSTRef vecRef nmv
writeSTRef lstRef $ lst ++ [str]
writeSTRef countRef 0
flushCurrentBuffer' :: BoolWriteStateRef s -> ST s ()
flushCurrentBuffer' :: forall s. BoolWriteStateRef s -> ST s ()
flushCurrentBuffer' BoolWriteStateRef s
st = do
count <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (STRef s Int -> ST s Int) -> STRef s Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ BoolWriteStateRef s -> STRef s Int
forall s. BoolWriteStateRef s -> STRef s Int
bwsWrittenWords BoolWriteStateRef s
st
when (count >= defaultBufferSize)
(forceBufferFlushing' st)
byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString
byteStringFromVector :: forall s. MVector s Word8 -> Int -> ST s ByteString
byteStringFromVector MVector s Word8
vec Int
size = do
frozen <- MVector (PrimState (ST s)) Word8 -> ST s (Vector Word8)
forall a (m :: * -> *).
(Storable a, PrimMonad m) =>
MVector (PrimState m) a -> m (Vector a)
VS.unsafeFreeze MVector s Word8
MVector (PrimState (ST s)) Word8
vec
return $ blitVector frozen 0 size
setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s ()
{-# INLINE setBitCount' #-}
setBitCount' :: forall s. BoolWriteStateRef s -> Word8 -> Int -> ST s ()
setBitCount' BoolWriteStateRef s
st Word8
acc Int
count = do
STRef s Word8 -> Word8 -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (BoolWriteStateRef s -> STRef s Word8
forall s. BoolWriteStateRef s -> STRef s Word8
bwsBitAcc BoolWriteStateRef s
st) Word8
acc
STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef (BoolWriteStateRef s -> STRef s Int
forall s. BoolWriteStateRef s -> STRef s Int
bwsBitReaded BoolWriteStateRef s
st) Int
count
resetBitCount' :: BoolWriteStateRef s -> ST s ()
{-# INLINE resetBitCount' #-}
resetBitCount' :: forall s. BoolWriteStateRef s -> ST s ()
resetBitCount' BoolWriteStateRef s
st = BoolWriteStateRef s -> Word8 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> Int -> ST s ()
setBitCount' BoolWriteStateRef s
st Word8
0 Int
0
pushByte' :: BoolWriteStateRef s -> Word8 -> ST s ()
{-# INLINE pushByte' #-}
pushByte' :: forall s. BoolWriteStateRef s -> Word8 -> ST s ()
pushByte' BoolWriteStateRef s
st Word8
v = do
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
flushCurrentBuffer' BoolWriteStateRef s
st
idx <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (BoolWriteStateRef s -> STRef s Int
forall s. BoolWriteStateRef s -> STRef s Int
bwsWrittenWords BoolWriteStateRef s
st)
vec <- readSTRef (bwsCurrBuffer st)
M.write vec idx v
writeSTRef (bwsWrittenWords st) $ idx + 1
flushLeftBits' :: BoolWriteStateRef s -> ST s ()
flushLeftBits' :: forall s. BoolWriteStateRef s -> ST s ()
flushLeftBits' BoolWriteStateRef s
st = do
currCount <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (STRef s Int -> ST s Int) -> STRef s Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ BoolWriteStateRef s -> STRef s Int
forall s. BoolWriteStateRef s -> STRef s Int
bwsBitReaded BoolWriteStateRef s
st
when (currCount > 0) $ do
currWord <- readSTRef $ bwsBitAcc st
pushByte' st $ currWord `unsafeShiftL` (8 - currCount)
writeBits' :: BoolWriteStateRef s
-> Word32
-> Int
-> ST s ()
{-# INLINE writeBits' #-}
writeBits' :: forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBits' BoolWriteStateRef s
st Word32
d Int
c = do
currWord <- STRef s Word8 -> ST s Word8
forall s a. STRef s a -> ST s a
readSTRef (STRef s Word8 -> ST s Word8) -> STRef s Word8 -> ST s Word8
forall a b. (a -> b) -> a -> b
$ BoolWriteStateRef s -> STRef s Word8
forall s. BoolWriteStateRef s -> STRef s Word8
bwsBitAcc BoolWriteStateRef s
st
currCount <- readSTRef $ bwsBitReaded st
serialize d c currWord currCount
where dumpByte :: Word8 -> ST s ()
dumpByte Word8
0xFF = BoolWriteStateRef s -> Word8 -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> ST s ()
pushByte' BoolWriteStateRef s
st Word8
0xFF ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BoolWriteStateRef s -> Word8 -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> ST s ()
pushByte' BoolWriteStateRef s
st Word8
0x00
dumpByte Word8
i = BoolWriteStateRef s -> Word8 -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> ST s ()
pushByte' BoolWriteStateRef s
st Word8
i
serialize :: Word32 -> Int -> Word8 -> Int -> ST s ()
serialize Word32
bitData Int
bitCount Word8
currentWord Int
count
| Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = do
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
resetBitCount' BoolWriteStateRef s
st
Word8 -> ST s ()
dumpByte (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ (Word8
currentWord Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
bitCount) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cleanData)
| Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 =
let newVal :: Word8
newVal = Word8
currentWord Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
bitCount
in BoolWriteStateRef s -> Word8 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> Int -> ST s ()
setBitCount' BoolWriteStateRef s
st (Word8
newVal Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cleanData) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bitCount
| Bool
otherwise =
let leftBitCount :: Int
leftBitCount = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
count :: Int
highPart :: Word32
highPart = Word32
cleanData Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` (Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftBitCount) :: Word32
prevPart :: Word32
prevPart = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
currentWord Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
leftBitCount :: Word32
nextMask :: Word32
nextMask = (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftBitCount)) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1 :: Word32
newData :: Word32
newData = Word32
cleanData Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
nextMask :: Word32
newCount :: Int
newCount = Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftBitCount :: Int
toWrite :: Word8
toWrite = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
prevPart Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
highPart :: Word8
in Word8 -> ST s ()
dumpByte Word8
toWrite ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Int -> Word8 -> Int -> ST s ()
serialize Word32
newData Int
newCount Word8
0 Int
0
where cleanMask :: Word32
cleanMask = (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
bitCount) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1 :: Word32
cleanData :: Word32
cleanData = Word32
bitData Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
cleanMask :: Word32
writeBitsGif :: BoolWriteStateRef s
-> Word32
-> Int
-> ST s ()
{-# INLINE writeBitsGif #-}
writeBitsGif :: forall s. BoolWriteStateRef s -> Word32 -> Int -> ST s ()
writeBitsGif BoolWriteStateRef s
st Word32
d Int
c = do
currWord <- STRef s Word8 -> ST s Word8
forall s a. STRef s a -> ST s a
readSTRef (STRef s Word8 -> ST s Word8) -> STRef s Word8 -> ST s Word8
forall a b. (a -> b) -> a -> b
$ BoolWriteStateRef s -> STRef s Word8
forall s. BoolWriteStateRef s -> STRef s Word8
bwsBitAcc BoolWriteStateRef s
st
currCount <- readSTRef $ bwsBitReaded st
serialize d c currWord currCount
where dumpByte :: Word8 -> ST s ()
dumpByte = BoolWriteStateRef s -> Word8 -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> ST s ()
pushByte' BoolWriteStateRef s
st
serialize :: Word32 -> Int -> Word8 -> Int -> ST s ()
serialize Word32
bitData Int
bitCount Word8
currentWord Int
count
| Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = do
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
resetBitCount' BoolWriteStateRef s
st
Word8 -> ST s ()
dumpByte (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8) -> Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ Word8
currentWord Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|.
(Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cleanData Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
count))
| Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 =
let newVal :: Word8
newVal = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
cleanData Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
count
in BoolWriteStateRef s -> Word8 -> Int -> ST s ()
forall s. BoolWriteStateRef s -> Word8 -> Int -> ST s ()
setBitCount' BoolWriteStateRef s
st (Word8
newVal Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
currentWord) (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bitCount
| Bool
otherwise =
let leftBitCount :: Int
leftBitCount = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
count :: Int
newData :: Word32
newData = Word32
cleanData Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
leftBitCount :: Word32
newCount :: Int
newCount = Int
bitCount Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
leftBitCount :: Int
toWrite :: Word8
toWrite = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
currentWord
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
cleanData Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
count) :: Word8
in Word8 -> ST s ()
dumpByte Word8
toWrite ST s () -> ST s () -> ST s ()
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Int -> Word8 -> Int -> ST s ()
serialize Word32
newData Int
newCount Word8
0 Int
0
where cleanMask :: Word32
cleanMask = (Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
bitCount) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1 :: Word32
cleanData :: Word32
cleanData = Word32
bitData Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
cleanMask :: Word32
finalizeBoolWriterGif :: BoolWriteStateRef s -> ST s L.ByteString
finalizeBoolWriterGif :: forall s. BoolWriteStateRef s -> ST s ByteString
finalizeBoolWriterGif BoolWriteStateRef s
st = do
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
flushLeftBitsGif BoolWriteStateRef s
st
BoolWriteStateRef s -> ST s ()
forall s. BoolWriteStateRef s -> ST s ()
forceBufferFlushing' BoolWriteStateRef s
st
[ByteString] -> ByteString
L.fromChunks ([ByteString] -> ByteString)
-> ST s [ByteString] -> ST s ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STRef s [ByteString] -> ST s [ByteString]
forall s a. STRef s a -> ST s a
readSTRef (BoolWriteStateRef s -> STRef s [ByteString]
forall s. BoolWriteStateRef s -> STRef s [ByteString]
bwsBufferList BoolWriteStateRef s
st)
flushLeftBitsGif :: BoolWriteStateRef s -> ST s ()
flushLeftBitsGif :: forall s. BoolWriteStateRef s -> ST s ()
flushLeftBitsGif BoolWriteStateRef s
st = do
currCount <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (STRef s Int -> ST s Int) -> STRef s Int -> ST s Int
forall a b. (a -> b) -> a -> b
$ BoolWriteStateRef s -> STRef s Int
forall s. BoolWriteStateRef s -> STRef s Int
bwsBitReaded BoolWriteStateRef s
st
when (currCount > 0) $ do
currWord <- readSTRef $ bwsBitAcc st
pushByte' st currWord
{-# ANN module "HLint: ignore Reduce duplication" #-}