@@ -55,7 +55,9 @@ module Data.Binary.Bits.Get
55 -- $bitget
55 -- $bitget
58 , runBitGet
59 , runBitGet
60 -- ** Get bytes
62 -- ** Get bytes
@@ -158,33 +160,10 @@ import GHC.Word
160data S = S {-# UNPACK #-} !ByteString -- Input
162data S = S {-# UNPACK #-} !ByteString -- Input
161− {-# UNPACK #-} !Int -- Bit offset (0-7)
163+ {-# UNPACK #-} !Int -- Bit offset (0-7)
164+ !BitOrder -- Bit order
162 deriving (Show)
165 deriving (Show)
164−-- | A block that will be read with only one boundary check. Needs to know the
165−-- number of bits in advance.
166−data Block a = Block Int (S -> a)
168−instance Functor Block where
169− fmap f (Block i p) = Block i (\s -> f (p s))
171−instance Applicative Block where
172− pure a = Block 0 (\_ -> a)
173− (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))
174− (Block i _) *> (Block j q) = Block (i+j) (q . incS i)
175− (Block i p) <* (Block j _) = Block (i+j) p
177−-- | Get a block. Will be read with one single boundry check, and
178−-- therefore requires a statically known number of bits.
179−-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be',
180−-- 'byteString' and 'Applicative'.
181−block :: Block a -> BitGet a
182−block (Block i p) = do
185− putState $! (incS i s)
188-- | Compute bit offset (equivalent to x `mod` 8 but faster)
167-- | Compute bit offset (equivalent to x `mod` 8 but faster)
189bit_offset :: Int -> Int
168bit_offset :: Int -> Int
190bit_offset n = make_mask 3 .&. n
169bit_offset n = make_mask 3 .&. n
@@ -197,12 +176,16 @@ byte_offset n = n `shiftR` 3
198-- | Increment the current bit offset
177-- | Increment the current bit offset
199incS :: Int -> S -> S
178incS :: Int -> S -> S
200−incS o (S bs n) = S (unsafeDrop d bs) n'
179+incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
202 !o' = (n+o)
181 !o' = (n+o)
203 !d = byte_offset o'
182 !d = byte_offset o'
204 !n' = bit_offset o'
183 !n' = bit_offset o'
185+-- | Select the bit ordering
186+selectBitOrderS :: BitOrder -> S -> S
187+selectBitOrderS bo (S bs o _) = S bs o bo
206-- | make_mask 3 = 00000111
189-- | make_mask 3 = 00000111
207make_mask :: (Bits a, Num a) => Int -> a
190make_mask :: (Bits a, Num a) => Int -> a
208make_mask n = (1 `shiftL` fromIntegral n) - 1
191make_mask n = (1 `shiftL` fromIntegral n) - 1
@@ -218,33 +201,6 @@ mask :: (Bits a, Num a) => Int -> a -> a
218mask n v = v .&. make_mask n
201mask n v = v .&. make_mask n
219{-# INLINE mask #-}
202{-# INLINE mask #-}
221−class FastBits a where
222− fastShiftR :: a -> Int -> a
223− fastShiftL :: a -> Int -> a
225− {-# INLINE fastShift #-}
226− fastShift :: a -> Int -> a
228− | n > 0 = fastShiftL x n
229− | n < 0 = fastShiftR x (negate n)
232−instance FastBits Word8 where
233− fastShiftR = shiftr_w8
234− fastShiftL = shiftl_w8
236−instance FastBits Word16 where
237− fastShiftR = shiftr_w16
238− fastShiftL = shiftl_w16
240−instance FastBits Word32 where
241− fastShiftR = shiftr_w32
242− fastShiftL = shiftl_w32
244−instance FastBits Word64 where
245− fastShiftR = shiftr_w64
246− fastShiftL = shiftl_w64
248-- | Bit order
204-- | Bit order
250-- E.g. two words of 5 bits: ABCDE, VWXYZ
206-- E.g. two words of 5 bits: ABCDE, VWXYZ
@@ -252,13 +208,14 @@ instance FastBits Word64 where
252-- - LB: XYZABCDE xxxxxxVW
208-- - LB: XYZABCDE xxxxxxVW
253-- - BL: EDCBAZYX WVxxxxxx -- not implemented
209-- - BL: EDCBAZYX WVxxxxxx -- not implemented
254-- - LL: XWVEDCBA xxxxxxZY -- not implemented
210-- - LL: XWVEDCBA xxxxxxZY -- not implemented
255−data BitOrder = BB | LB
211+data BitOrder = BB | LB deriving (Show)
258-- | Read a single bit
214-- | Read a single bit
259−readBool :: BitOrder -> S -> Bool
215+readBool :: S -> Bool
216+readBool (S bs o bo) = case bo of
260−readBool BB (S bs n) = testBit (unsafeHead bs) (7-n)
217+ BB -> testBit (unsafeHead bs) (7-o)
261−readBool LB (S bs n) = testBit (unsafeHead bs) n
218+ LB -> testBit (unsafeHead bs) o
263-- | Extract a range of bits from (ws :: ByteString)
220-- | Extract a range of bits from (ws :: ByteString)
@@ -269,9 +226,9 @@ extract bo bs o n
269 | B.length bs == 0 = error "Empty ByteString"
226 | B.length bs == 0 = error "Empty ByteString"
270 | otherwise = mask n (foldlWithIndex' f 0 bs)
227 | otherwise = mask n (foldlWithIndex' f 0 bs)
272− -- foldl' with index
229+ -- B.foldl' with index
273− foldlWithIndex' f b = fst . B.foldl' g (b,0)
230+ foldlWithIndex' op b = fst . B.foldl' g (b,0)
274− where g (b,i) w = (f b w i, (i+1))
231+ where g (b',i) w = (op b' w i, (i+1))
276 -- 'or' correctly shifted words
233 -- 'or' correctly shifted words
277 f b w i = b .|. (fromIntegral w `fastShift` off i)
234 f b w i = b .|. (fromIntegral w `fastShift` off i)
@@ -286,8 +243,8 @@ extract bo bs o n
288-- | Generic readWord
245-- | Generic readWord
289−readWord :: (Num a, Bits a, FastBits a) => BitOrder -> Int -> S -> a
246+readWord :: (Num a, Bits a, FastBits a) => Int -> S -> a
290−readWord bo n (S bs o)
247+readWord n (S bs o bo)
291 | n == 0 = 0
248 | n == 0 = 0
292 | o+n <= 8 = extract bo (unsafeTake 1 bs) o n
249 | o+n <= 8 = extract bo (unsafeTake 1 bs) o n
293 | o+n <= 16 = extract bo (unsafeTake 2 bs) o n
250 | o+n <= 16 = extract bo (unsafeTake 2 bs) o n
@@ -299,30 +256,20 @@ readWord bo n (S bs o)
299 | o+n <= 64 = extract bo (unsafeTake 8 bs) o n
256 | o+n <= 64 = extract bo (unsafeTake 8 bs) o n
300 | otherwise = extract bo (unsafeTake ((o+n+7) `div` 8) bs) o n
257 | otherwise = extract bo (unsafeTake ((o+n+7) `div` 8) bs) o n
259+-- | Check that the number of bits to read is not greater than the first parameter
260+{-# INLINE readWordChecked #-}
302−readWordChecked :: (Num a, Bits a, FastBits a) => Int -> BitOrder -> Int -> S -> a
261+readWordChecked :: (Num a, Bits a, FastBits a) => Int -> Int -> S -> a
303−readWordChecked m bo n s
262+readWordChecked m n s
304 | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"
263 | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"
305− | otherwise = readWord bo n s
264+ | otherwise = readWord n s
307−{-# INLINE readWord8 #-}
308−readWord8 :: BitOrder -> Int -> S -> Word8
309−readWord8 = readWordChecked 8
311−{-# INLINE readWord16 #-}
312−readWord16 :: BitOrder -> Int -> S -> Word16
313−readWord16 = readWordChecked 16
315−{-# INLINE readWord32 #-}
316−readWord32 :: BitOrder -> Int -> S -> Word32
317−readWord32 = readWordChecked 32
319−{-# INLINE readWord64 #-}
320−readWord64 :: BitOrder -> Int -> S -> Word64
321−readWord64 = readWordChecked 64
323-- | Read the given number of bytes and return them in Big-Endian order
266-- | Read the given number of bytes and return them in Big-Endian order
269+-- BB: xxxABCDE FGHIJKLM NOPQRxxx -> ABCDEFGH IJKLMNOP QRxxxxxx
270+-- LB: NOPQRxxx FGHIJKLM xxxABCDE -> ABCDEFGH IJKLMNOP QRxxxxxx
324−readByteString :: BitOrder -> Int -> S -> ByteString
271+readByteString :: Int -> S -> ByteString
325−readByteString bo n (S bs o)
272+readByteString n (S bs o bo)
326 | o == 0 = unsafeTake n bs
273 | o == 0 = unsafeTake n bs
327 | otherwise = unsafePerformIO $ do
274 | otherwise = unsafePerformIO $ do
328 let len = n+1
275 let len = n+1
@@ -357,7 +304,7 @@ newtype BitGet a = B { runState :: S -> Get (S,a) }
358instance Monad BitGet where
305instance Monad BitGet where
359 return x = B $ \s -> return (s,x)
306 return x = B $ \s -> return (s,x)
360− fail str = B $ \(S inp n) -> putBackState inp n >> fail str
307+ fail str = B $ \s -> putBackState s >> fail str
361 (B f) >>= g = B $ \s -> do (s',a) <- f s
308 (B f) >>= g = B $ \s -> do (s',a) <- f s
362 runState (g a) s'
309 runState (g a) s'
@@ -373,20 +320,23 @@ instance Applicative BitGet where
373runBitGet :: BitGet a -> Get a
320runBitGet :: BitGet a -> Get a
374runBitGet bg = do
321runBitGet bg = do
375 s <- mkInitState
322 s <- mkInitState
376− ((S str' n),a) <- runState bg s
323+ (s',a) <- runState bg s
377− putBackState str' n
324+ putBackState s'
380mkInitState :: Get S
327mkInitState :: Get S
381mkInitState = do
328mkInitState = do
382− str <- get
329+ bs <- get
383 put B.empty
330 put B.empty
384− return (S str 0)
331+ return (S bs 0 BB)
386−putBackState :: B.ByteString -> Int -> Get ()
333+putBackState :: S -> Get ()
387−putBackState bs n = do
334+putBackState (S bs o _) = do
388 remaining <- get
335 remaining <- get
338+ _ -> unsafeDrop 1 bs
389− put (B.drop (if n==0 then 0 else 1) bs `B.append` remaining)
339+ put (bs' `B.append` remaining)
391getState :: BitGet S
341getState :: BitGet S
392getState = B $ \s -> return (s,s)
342getState = B $ \s -> return (s,s)
@@ -394,32 +344,47 @@ getState = B $ \s -> return (s,s)
394putState :: S -> BitGet ()
344putState :: S -> BitGet ()
395putState s = B $ \_ -> return (s,())
345putState s = B $ \_ -> return (s,())
347+withState :: (S -> S) -> BitGet ()
397-- | Make sure there are at least @n@ bits.
352-- | Make sure there are at least @n@ bits.
398ensureBits :: Int -> BitGet ()
353ensureBits :: Int -> BitGet ()
399ensureBits n = do
354ensureBits n = do
400− (S bs o) <- getState
355+ (S bs o bo) <- getState
401 if n <= (B.length bs * 8 - o)
356 if n <= (B.length bs * 8 - o)
402 then return ()
357 then return ()
403 else do let currentBits = B.length bs * 8 - o
358 else do let currentBits = B.length bs * 8 - o
404− let byteCount = (n - currentBits + 7) `div` 8
359+ let byteCount = byte_offset (n - currentBits + 7)
405 B $ \_ -> do B.ensureN byteCount
360 B $ \_ -> do B.ensureN byteCount
406 bs' <- B.get
361 bs' <- B.get
407 put B.empty
362 put B.empty
408− return (S (bs`append`bs') o, ())
363+ return (S (bs`append`bs') o bo, ())
410-- | Skip the given number of bits
365-- | Skip the given number of bits
411skipBits :: Int -> BitGet ()
366skipBits :: Int -> BitGet ()
412skipBits n = do
367skipBits n = do
413 ensureBits n
368 ensureBits n
414− s <- getState
369+ withState (incS n)
415− putState $! (incS n s)
417-- | Skip bits if necessary to align to the next byte
371-- | Skip bits if necessary to align to the next byte
418alignByte :: BitGet ()
372alignByte :: BitGet ()
419alignByte = do
373alignByte = do
420− (S _ n) <- getState
374+ (S _ o _) <- getState
421− when (n /= 0) $
375+ when (o /= 0) $
422− skipBits (8-n)
376+ skipBits (8-o)
378+-- | Select the bit ordering
379+selectBitOrder :: BitOrder -> BitGet ()
380+selectBitOrder = withState . selectBitOrderS
382+-- | Test whether all input has been consumed, i.e. there are no remaining
384+isEmpty :: BitGet Bool
385+isEmpty = B $ \ (S bs o bo) -> if B.null bs
386+ then B.isEmpty >>= \e -> return (S bs o bo, e)
387+ else return (S bs o bo, False)
424-- | Get 1 bit as a 'Bool'.
389-- | Get 1 bit as a 'Bool'.
425getBool :: BitGet Bool
390getBool :: BitGet Bool
@@ -448,48 +413,99 @@ getByteString n = block (byteString n)
448-- | Get @n@ bytes as a lazy ByteString.
413-- | Get @n@ bytes as a lazy ByteString.
449getLazyByteString :: Int -> BitGet L.ByteString
414getLazyByteString :: Int -> BitGet L.ByteString
450getLazyByteString n = do
415getLazyByteString n = do
451− (S _ o) <- getState
416+ (S _ o bo) <- getState
452 case o of
417 case o of
453− 0 -> B $ \ (S bs o') -> do
418+ 0 -> B $ \s -> do
454− putBackState bs o'
419+ putBackState s
455 lbs <- B.getLazyByteString (fromIntegral n)
420 lbs <- B.getLazyByteString (fromIntegral n)
456− return (S B.empty 0, lbs)
421+ return (S B.empty 0 bo, lbs)
457 _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n
422 _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n
459−-- | Test whether all input has been consumed, i.e. there are no remaining
424+
460−-- undecoded bytes.
425+
461−isEmpty :: BitGet Bool
426+
462−isEmpty = B $ \ (S bs o) -> if B.null bs
427+
463− then B.isEmpty >>= \e -> return (S bs o, e)
428+-- | A block that will be read with only one boundary check. Needs to know the
429+-- number of bits in advance.
430+data Block a = Block Int (S -> a)
432+instance Functor Block where
433+ fmap f (Block i p) = Block i (\s -> f (p s))
435+instance Applicative Block where
436+ pure a = Block 0 (\_ -> a)
437+ (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))
438+ (Block i _) *> (Block j q) = Block (i+j) (q . incS i)
439+ (Block i p) <* (Block j _) = Block (i+j) p
441+-- | Get a block. Will be read with one single boundry check, and
442+-- therefore requires a statically known number of bits.
443+-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be',
444+-- 'byteString' and 'Applicative'.
445+block :: Block a -> BitGet a
446+block (Block i p) = do
449+ putState $! (incS i s)
464− else return (S bs o, False)
450+ return $! p s
466-- | Read a 1 bit 'Bool'.
452-- | Read a 1 bit 'Bool'.
467bool :: Block Bool
453bool :: Block Bool
468−bool = Block 1 (readBool BB)
454+bool = Block 1 readBool
470-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
456-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
471word8 :: Int -> Block Word8
457word8 :: Int -> Block Word8
472−word8 n = Block n (readWord8 BB n)
458+word8 n = Block n (readWordChecked 8 n)
474-- | Read @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
460-- | Read @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
475word16be :: Int -> Block Word16
461word16be :: Int -> Block Word16
476−word16be n = Block n (readWord16 BB n)
462+word16be n = Block n (readWordChecked 16 n)
478-- | Read @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
464-- | Read @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
479word32be :: Int -> Block Word32
465word32be :: Int -> Block Word32
480−word32be n = Block n (readWord32 BB n)
466+word32be n = Block n (readWordChecked 32 n)
482-- | Read @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
468-- | Read @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
483word64be :: Int -> Block Word64
469word64be :: Int -> Block Word64
484−word64be n = Block n (readWord64 BB n)
470+word64be n = Block n (readWordChecked 64 n)
486-- | Read @n@ bytes as a 'ByteString'.
472-- | Read @n@ bytes as a 'ByteString'.
487byteString :: Int -> Block ByteString
473byteString :: Int -> Block ByteString
488−byteString n | n > 0 = Block (n*8) (readByteString BB n)
474+byteString n | n > 0 = Block (n*8) (readByteString n)
489 | otherwise = Block 0 (\_ -> B.empty)
475 | otherwise = Block 0 (\_ -> B.empty)
491−------------------------------------------------------------------------
477+
478+---------------------------------------------------------------------
492−-- Unchecked shifts, from the package binary
479+-- Unchecked shifts, from the "binary" package
481+-- | Class for types supporting fast bit shifting
482+class FastBits a where
483+ fastShiftR :: a -> Int -> a
484+ fastShiftL :: a -> Int -> a
486+ {-# INLINE fastShift #-}
487+ fastShift :: a -> Int -> a
489+ | n > 0 = fastShiftL x n
490+ | n < 0 = fastShiftR x (negate n)
493+instance FastBits Word8 where
494+ fastShiftR = shiftr_w8
495+ fastShiftL = shiftl_w8
497+instance FastBits Word16 where
498+ fastShiftR = shiftr_w16
499+ fastShiftL = shiftl_w16
501+instance FastBits Word32 where
502+ fastShiftR = shiftr_w32
503+ fastShiftL = shiftl_w32
505+instance FastBits Word64 where
506+ fastShiftR = shiftr_w64
507+ fastShiftL = shiftl_w64
494shiftl_w8 :: Word8 -> Int -> Word8
510shiftl_w8 :: Word8 -> Int -> Word8
495shiftl_w16 :: Word16 -> Int -> Word16
511shiftl_w16 :: Word16 -> Int -> Word16