@@ -1,439 +1,496 @@
1−{-# LANGUAGE RankNTypes, MagicHash, CPP #-}
1+{-# LANGUAGE RankNTypes, MagicHash, BangPatterns, CPP #-}
2+
3+-----------------------------------------------------------------------------
4+-- |
5+-- Module : Data.Binary.Bits.Get
6+-- Copyright : (c) Lennart Kolmodin 2010-2011
7+-- (c) Sylvain Henry 2015
8+-- License : BSD3-style (see LICENSE)
9+--
10+-- Maintainer : kolmodin@gmail.com
11+-- Stability : experimental
12+-- Portability : portable (should run where the package binary runs)
13+--
14+-- Parse bits easily. Parsing can be done either in a monadic style, or more
15+-- efficiently, using the 'Applicative' style.
16+--
17+-- For the monadic style, write your parser as a 'BitGet' monad using the
18+--
19+-- * 'getBool'
20+--
21+-- * 'getWord8'
22+--
23+-- * 'getWord16be'
24+--
25+-- * 'getWord32be'
26+--
27+-- * 'getWord64be'
28+--
29+-- * 'getByteString'
30+--
31+-- functions and run it with 'runBitGet'.
32+--
33+-- For the applicative style, compose the fuctions
34+--
35+-- * 'bool'
36+--
37+-- * 'word8'
38+--
39+-- * 'word16be'
40+--
41+-- * 'word32be'
42+--
43+-- * 'word64be'
44+--
45+-- * 'byteString'
46+--
47+-- to make a 'Block'.
48+-- Use 'block' to turn it into the 'BitGet' monad to be able to run it with
49+-- 'runBitGet'.
50+-----------------------------------------------------------------------------
251
352module Data.Binary.Bits.Get
4− ( T(..)
53+ (
54+ -- * BitGet monad
55+
56+ -- $bitget
57+
58+ BitGet
559 , runBitGet
6− , runBitGetSimple
7− , BitGet
8− -- , joinGet
960
61+ -- ** Get bytes
1062 , getBool
63+ , getBool#
1164 , getWord8
65+ , getWord16
66+ , getWord32
67+ , getWord64
1268 , getWord16be
1369 , getWord32be
1470 , getWord64be
1571
72+ -- ** Skip bits
73+ , skipBits
74+ , alignByte
75+
76+ -- * Blocks
77+
78+ -- $blocks
79+ , Block
80+ , block
81+
82+ -- ** Read in Blocks
83+ , bool
84+ , word8
85+ , word16
86+ , word32
87+ , word64
88+ , word16be
89+ , word32be
90+ , word64be
91+ , byteString
1692 , Data.Binary.Bits.Get.getByteString
17−
18− , readBool
19− , readWord8
20− , readWord16be
93+ , Data.Binary.Bits.Get.getLazyByteString
94+ , Data.Binary.Bits.Get.isEmpty
2195
2296 ) where
2397
24−import Data.Binary.Get as B ( runGet, Get, getByteString )
98+import Data.Binary.Get as B ( Get, getLazyByteString, isEmpty )
99+import Data.Binary.Get.Internal as B ( get, put, ensureN )
100+import Data.Binary.Bits.BitOrder
101+import Data.Binary.Bits.Internal
102+import Data.Binary.Bits.Alignment
25103
26104import Data.ByteString as B
27−import Data.ByteString.Internal
28−import Data.ByteString.Unsafe
29−
30105import qualified Data.ByteString.Lazy as L
106+import Data.ByteString.Unsafe
107+import Foreign.Marshal.Alloc (mallocBytes)
108+import Foreign.Ptr
109+import Foreign.Storable (poke)
110+import System.IO.Unsafe (unsafePerformIO)
31111
32112import Data.Bits
33113import Data.Word
34−import Data.List as List ( reverse )
35−
36114import Control.Applicative
115+import Control.Monad (when,foldM_)
37116
38−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
39−import GHC.Base hiding ( (:*:) )
117+import Prelude as P
40118import GHC.Word
41−import GHC.Int
42−#endif
43−
44−data T a b = !a :*: !b deriving (Show)
45−
46−data S = S !ByteString -- ^ Input
47− !Int -- ^ Bit offset (0-7)
119+import GHC.Base (uncheckedShiftLWord8#, wordToWord8#, Int (..), andWord8#, Word8#, (-#), Int#, xorI#, eqWord8#, TYPE)
120+
121+-- $bitget
122+-- Parse bits using a monad.
123+--
124+-- @
125+--myBitParser :: 'Get' ('Word8', 'Word8')
126+--myBitParser = 'runGetBit' parse4by4
127+--
128+--parse4by4 :: 'BitGet' ('Word8', 'Word8')
129+--parse4by4 = do
130+-- bits <- 'getWord8' 4
131+-- more <- 'getWord8' 4
132+-- return (bits,more)
133+-- @
134+
135+-- $blocks
136+-- Parse more efficiently in blocks. Each block is read with only one boundry
137+-- check (checking that there is enough input) as the size of the block can be
138+-- calculated statically. This is somewhat limiting as you cannot make the
139+-- parsing depend on the input being parsed.
140+--
141+-- @
142+--data IPV6Header = IPV6Header {
143+-- ipv6Version :: 'Word8'
144+-- , ipv6TrafficClass :: 'Word8'
145+-- , ipv6FlowLabel :: 'Word32
146+-- , ipv6PayloadLength :: 'Word16'
147+-- , ipv6NextHeader :: 'Word8'
148+-- , ipv6HopLimit :: 'Word8'
149+-- , ipv6SourceAddress :: 'ByteString'
150+-- , ipv6DestinationAddress :: 'ByteString'
151+-- }
152+--
153+-- ipv6headerblock =
154+-- IPV6Header '<$>' 'word8' 4
155+-- '<*>' 'word8' 8
156+-- '<*>' 'word32be' 24
157+-- '<*>' 'word16be' 16
158+-- '<*>' 'word8' 8
159+-- '<*>' 'word8' 8
160+-- '<*>' 'byteString' 16
161+-- '<*>' 'byteString' 16
162+--
163+--ipv6Header :: 'Get' IPV6Header
164+--ipv6Header = 'runBitGet' ('block' ipv6headerblock)
165+-- @
166+
167+data S = S {-# UNPACK #-} !ByteString -- Input
168+ {-# UNPACK #-} !Int -- Bit offset (0-7)
169+ !BitOrder -- Bit order
48170 deriving (Show)
49171
50−-- | make_mask 3 = 00000111
51−make_mask :: Bits a => Int -> a
52−make_mask n = (1 `shiftL` fromIntegral n) - 1
53−{-# SPECIALIZE make_mask :: Int -> Word #-}
54−{-# SPECIALIZE make_mask :: Int -> Word8 #-}
55−{-# SPECIALIZE make_mask :: Int -> Word16 #-}
56−{-# SPECIALIZE make_mask :: Int -> Word32 #-}
57−{-# SPECIALIZE make_mask :: Int -> Word64 #-}
58−
59−readBool :: S -> T Bool S
60−readBool s@(S bs n) = testBit (unsafeHead bs) (7-n) :*: incS s 1
61−
62−incS :: S -> Int -> S
63−incS (S bs n) 1 =
64− let
65− n' = n + 1
66− s' | n' == 8 = S (unsafeTail bs) 0
67− | otherwise = S bs n'
68− in s'
69−incS (S bs n) o =
70− let (d,n') = divMod (n+o) 8
71− in S (unsafeDrop d bs) n'
72−
73−{-
74−joinGet :: Get a -> BitGet a
75−joinGet m = C $ \s@(S bs o) kf ks -> do
76− -- put back the rest of the current chunk
77− case o of
78− 0 -> putS bs
79− _ -> putS (unsafeTail bs)
80− -- run the get function
81− a <- m
82− -- whatever is left, get it and us it as our state
83− bs' <- getS
84− let s' = S bs' 0
85− ks s' a
86−-}
87−
88−readByteString :: S -> Int -> T ByteString S
89−readByteString s@(S bs o) n
90− | o == 0 = unsafeTake n bs :*: (S (unsafeDrop n bs) 0)
91− | otherwise = unsafeTake n (unsafeTail bs) :*: (S (unsafeDrop (n+1) bs) 0)
92−
93−readWord8 :: S -> Int -> T Word8 S
94−readWord8 s@(S bs o) n
95− -- no bits at all, return 0
96− | n == 0 = 0 :*: s
97−
98− -- all bits are in the same byte
99− -- we just need to shift and mask them right
100− | n <= 8 - o = let w = unsafeHead bs
101− m = make_mask n
102− w' = (w `shiftr_w8` (8 - o - n)) .&. m
103− in w' :*: incS s n
104−
105− -- the bits are in two different bytes
106− -- make a word16 using both bytes, and then shift and mask
107− | n <= 8 = let w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.
108− (fromIntegral (unsafeIndex bs 1))
109− m = make_mask n
110− w' = (w `shiftr_w16` (16 - o - n)) .&. m
111− in fromIntegral w' :*: incS s n
112−
113−bit_offset :: Int -> Int
114−bit_offset n = make_mask 3 .&. n
115−
116−byte_offset :: Int -> Int
117−byte_offset n = n `shiftR` 3
118−
119−readWord16be :: S -> Int -> T Word16 S
120−readWord16be s@(S bs o) n
172+-- | Increment the current bit offset
173+incS :: Int -> S -> S
174+incS o (S bs n bo) = S (unsafeDrop d bs) n' bo
175+ where
176+ !o' = (n+o)
177+ !d = byte_offset o'
178+ !n' = bit_offset o'
179+
180+-- | Read a single bit
181+readBool :: S -> Bool
182+readBool (S bs o bo) = case bo of
183+ BB -> testBit (unsafeHead bs) (7-o)
184+ BL -> testBit (unsafeHead bs) (7-o)
185+ LL -> testBit (unsafeHead bs) o
186+ LB -> testBit (unsafeHead bs) o
187+
188+-- | Read a single bit
189+readBool# :: S -> Int
190+readBool# (S bs (I# o) bo) = case bo of
191+ BB -> testBit# (7# -# o)
192+ BL -> testBit# (7# -# o)
193+ LL -> testBit# o
194+ LB -> testBit# o
195+ where
196+ !(W8# w) = unsafeHead bs
197+ testBit# n = I# (((w `andWord8#` (wordToWord8# 1## `uncheckedShiftLWord8#` n)) `eqWord8#` wordToWord8# 0##) `xorI#` 1#)
198+
199+
200+-- | Extract a range of bits from (ws :: ByteString)
201+--
202+-- Constraint: 8 * (length ws -1 ) < o+n <= 8 * length ws
203+extract :: (Num a, FastBits a) => BitOrder -> ByteString -> Int -> Int -> a
204+extract bo bs o n
205+ | n == 0 = 0
206+ | B.length bs == 0 = error "Empty ByteString"
207+ | otherwise = rev . mask n . foldlWithIndex' f 0 $ bs
208+ where
209+ -- B.foldl' with index
210+ foldlWithIndex' op b = fst . B.foldl' g (b,0)
211+ where g (b',i) w = (op b' w i, (i+1))
212+
213+ -- 'or' correctly shifted words
214+ f b w i = b .|. (fromIntegral w `fastShift` off i)
215+
216+ -- co-offset
217+ r = B.length bs * 8 - (o + n)
218+
219+ -- shift offset depending on the byte position (0..B.length-1)
220+ off i = case bo of
221+ LL -> 8*i - o
222+ LB -> 8*i - o
223+ BB -> (B.length bs -1 - i) * 8 - r
224+ BL -> (B.length bs -1 - i) * 8 - r
225+
226+ -- reverse bits if necessary
227+ rev = case bo of
228+ LB -> reverseBits n
229+ BL -> reverseBits n
230+ BB -> id
231+ LL -> id
232+
233+
234+-- | Generic readWord
235+readWord :: (Num a, FastBits a) => Int -> S -> a
236+readWord n (S bs o bo)
237+ | n == 0 = 0
238+ | otherwise = extract bo (unsafeTake nbytes bs) o n
239+ where nbytes = byte_offset (o+n+7)
240+
241+-- | Check that the number of bits to read is not greater than the first parameter
242+{-# INLINE readWordChecked #-}
243+readWordChecked :: (Num a, FastBits a) => Int -> Int -> S -> a
244+readWordChecked m n s
245+ | n > m = error $ "Tried to read more than " ++ show m ++ " bits (" ++ show n ++")"
246+ | otherwise = readWord n s
247+
248+-- | Read the given number of bytes and return them in Big-Endian order
249+--
250+-- Examples:
251+-- BB: xxxABCDE FGHIJKLM NOPxxxxx -> ABCDEFGH IJKLMNOP
252+-- LL: LMNOPxxx DEFGHIJK xxxxxABC -> ABCDEFGH IJKLMNOP
253+-- BL: xxxPONML KJIHGFED CBAxxxxx -> ABCDEFGH IJKLMNOP
254+-- LB: EDCBAxxx MLKJIHGF xxxxxPON -> ABCDEFGH IJKLMNOP
255+readByteString :: Int -> S -> ByteString
256+readByteString n (S bs o bo) =
257+ let
258+ bs' = unsafeTake (n+1) bs
259+ bs'' = unsafeTake n bs
260+ rev = B.map (reverseBits 8)
261+ in case (o,bo) of
262+ (0,BB) -> bs''
263+ (0,LL) -> B.reverse bs''
264+ (0,LB) -> rev bs''
265+ (0,BL) -> rev . B.reverse $ bs''
266+ (_,LL) -> readByteString n (S (B.reverse bs') (8-o) BB)
267+ (_,BL) -> rev . B.reverse $ readByteString n (S bs' o BB)
268+ (_,LB) -> rev . B.reverse $ readByteString n (S bs' o LL)
269+ (_,BB) -> unsafePerformIO $ do
270+ let len = n+1
271+ ptr <- mallocBytes len
272+ let f r i = do
273+ let
274+ w = unsafeIndex bs (len-i)
275+ w' = (w `fastShiftL` o) .|. r
276+ r' = w `fastShiftR` (8-o)
277+ poke (ptr `plusPtr` (len-i)) w'
278+ return r'
279+ foldM_ f 0 [1..len]
280+ unsafeInit <$> unsafePackMallocCStringLen (ptr,len)
121281
122− -- 8 or fewer bits, use readWord8
123− | n <= 8 = let w :*: s' = readWord8 s n
124− in fromIntegral w :*: s'
125282
126− -- handle 9 or more bits, stored in two bytes
127−
128− -- no offset, plain and simple 16 bytes
129− | o == 0 && n == 16 = let msb = fromIntegral (unsafeHead bs)
130− lsb = fromIntegral (unsafeIndex bs 1)
131− w = (msb `shiftl_w16` 8) .|. lsb
132− in w :*: incS s n
133−
134− -- no offset, but not full 16 bytes
135− | o == 0 = let msb = fromIntegral (unsafeHead bs)
136− lsb = fromIntegral (unsafeIndex bs 1)
137− w = (msb `shiftl_w16` (n-8)) .|. (lsb `shiftr_w16` (16-n))
138− in w :*: incS s n
139−
140− -- with offset, and n=9-16
141− | n <= 16 = readWithOffset s shiftl_w16 shiftr_w16 n
142−
143− | otherwise = error "readWord16be: tried to read more than 16 bits"
144−
145−readWithoutOffset :: (Bits a, Num a)
146− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> T a S
147−readWithoutOffset s@(S bs o) shifterL shifterR n
148− | o /= 0 = error "readWithoutOffset: there is an offset"
283+------------------------------------------------------------------------
284+-- | 'BitGet' is a monad, applicative and a functor. See 'runBitGet'
285+-- for how to run it.
286+newtype BitGet a = B { runState :: S -> Get (S,a) }
149287
150− | bit_offset n == 0 && byte_offset n <= 4 =
151− let segs = byte_offset n
152− bn 0 = fromIntegral (unsafeHead bs)
153− bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
288+instance Monad BitGet where
289+ return x = B $ \s -> return (s,x)
290+ (B f) >>= g = B $ \s -> do (s',a) <- f s
291+ runState (g a) s'
154292
155− in (bn (segs-1) :*: incS s n)
293+instance Functor BitGet where
294+ fmap f m = m >>= \a -> return (f a)
156295
157− | n <= 64 = let segs = byte_offset n
158− o' = bit_offset (n - 8 + o)
296+instance Applicative BitGet where
297+ pure x = return x
298+ fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
159299
160− bn 0 = fromIntegral (unsafeHead bs)
161− bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
300+instance BitOrderable BitGet where
301+ setBitOrder bo = do
302+ (S bs o _) <- getState
303+ putState (S bs o bo)
162304
163− msegs = bn (segs-1) `shifterL` o'
305+ getBitOrder = do
306+ (S _ _ bo) <- getState
307+ return bo
164308
165− last = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')
309+instance Alignable BitGet where
310+ -- | Skip the given number of bits
311+ skipBits n = do
312+ ensureBits n
313+ withState (incS n)
166314
167− w = msegs .|. last
168− in w :*: incS s n
315+ -- | Skip bits if necessary to align to the next byte
316+ alignByte = do
317+ (S _ o _) <- getState
318+ when (o /= 0) $
319+ skipBits (8-o)
169320
170−readWithOffset :: (Bits a, Num a)
171− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> T a S
172−readWithOffset s@(S bs o) shifterL shifterR n
173− | n <= 64 = let bits_in_msb = 8 - o
174− (n',top) = (n - bits_in_msb
175− , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')
176−
177− segs = byte_offset n'
178321
179− bn 0 = 0
180− bn 1 = fromIntegral (unsafeIndex bs 1)
181− bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
182322
183− o' = bit_offset n'
323+-- | Run a 'BitGet' within the Binary packages 'Get' monad. If a byte has
324+-- been partially consumed it will be discarded once 'runBitGet' is finished.
325+runBitGet :: BitGet a -> Get a
326+runBitGet bg = do
327+ s <- mkInitState
328+ (s',a) <- runState bg s
329+ putBackState s'
330+ return a
184331
185− mseg = bn segs `shifterL` o'
332+mkInitState :: Get S
333+mkInitState = do
334+ bs <- get
335+ put B.empty
336+ return (S bs 0 BB)
186337
187− last | o' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shifterR` (8 - o')
188− | otherwise = 0
338+putBackState :: S -> Get ()
339+putBackState (S bs o _) = do
340+ remaining <- get
341+ let bs' = case o of
342+ 0 -> bs
343+ _ -> unsafeDrop 1 bs
344+ put (bs' `B.append` remaining)
189345
190− w = top .|. mseg .|. last
191− in w :*: incS s n
346+getState :: BitGet S
347+getState = B $ \s -> return (s,s)
192348
349+putState :: S -> BitGet ()
350+putState s = B $ \_ -> return (s,())
193351
194−readWord32be :: S -> Int -> T Word32 S
195−readWord32be s@(S bs o) n
196− -- 8 or fewer bits, use readWord8
197− | n <= 8 = let w :*: s' = readWord8 s n
198− in fromIntegral w :*: s'
352+withState :: (S -> S) -> BitGet ()
353+withState f = do
354+ s <- getState
355+ putState $! f s
199356
200− -- 16 or fewer bits, use readWord16be
201− | n <= 16 = let w :*: s' = readWord16be s n
202− in fromIntegral w :*: s'
357+-- | Make sure there are at least @n@ bits.
358+ensureBits :: Int -> BitGet ()
359+ensureBits n = do
360+ (S bs o bo) <- getState
361+ if n <= (B.length bs * 8 - o)
362+ then return ()
363+ else do let currentBits = B.length bs * 8 - o
364+ let byteCount = byte_offset (n - currentBits + 7)
365+ B $ \_ -> do B.ensureN byteCount
366+ bs' <- B.get
367+ put B.empty
368+ return (S (bs`append`bs') o bo, ())
369+
370+-- | Test whether all input has been consumed, i.e. there are no remaining
371+-- undecoded bytes.
372+isEmpty :: BitGet Bool
373+isEmpty = B $ \ (S bs o bo) -> if B.null bs
374+ then B.isEmpty >>= \e -> return (S bs o bo, e)
375+ else return (S bs o bo, False)
376+
377+-- | Get 1 bit as a 'Bool'.
378+getBool :: BitGet Bool
379+getBool = block bool
203380
204− | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
381+-- | Get 1 bit as a 'Bool'.
382+getBool# :: BitGet Int
383+getBool# = block bool#
205384
206− | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
385+-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
386+getWord8 :: Int -> BitGet Word8
387+getWord8 n = block (word8 n)
207388
208− | otherwise = error "readWord32be: tried to read more than 32 bits"
389+-- | Get @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
390+getWord16 :: Int -> BitGet Word16
391+getWord16 n = block (word16 n)
209392
393+getWord16be :: Int -> BitGet Word16
394+getWord16be = getWord16
395+{-# DEPRECATED getWord16be "Use 'getWord16' instead" #-}
210396
211−readWord64be :: S -> Int -> T Word64 S
212−readWord64be s@(S bs o) n
213− -- 8 or fewer bits, use readWord8
214− | n <= 8 = let w :*: s' = readWord8 s n
215− in fromIntegral w :*: s'
397+-- | Get @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
398+getWord32 :: Int -> BitGet Word32
399+getWord32 n = block (word32 n)
216400
217− -- 16 or fewer bits, use readWord16be
218− | n <= 16 = let w :*: s' = readWord16be s n
219− in fromIntegral w :*: s'
401+getWord32be :: Int -> BitGet Word32
402+getWord32be = getWord32
403+{-# DEPRECATED getWord32be "Use 'getWord32' instead" #-}
220404
221− | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n
405+-- | Get @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
406+getWord64 :: Int -> BitGet Word64
407+getWord64 n = block (word64 n)
222408
223− | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n
409+getWord64be :: Int -> BitGet Word64
410+getWord64be = getWord64
411+{-# DEPRECATED getWord64be "Use 'getWord64' instead" #-}
224412
225− | otherwise = error "readWord64be: tried to read more than 64 bits"
413+-- | Get @n@ bytes as a 'ByteString'.
414+getByteString :: Int -> BitGet ByteString
415+getByteString n = block (byteString n)
226416
227−------------------------------------------------------------------------
228−-- unrolled codensity/state monad
229−newtype BitGet a = C { runCont :: forall r.
230− S ->
231− Failure r ->
232− Success a r ->
233− Get (Either String r) }
417+-- | Get @n@ bytes as a lazy ByteString.
418+getLazyByteString :: Int -> BitGet L.ByteString
419+getLazyByteString n = do
420+ (S _ o bo) <- getState
421+ case o of
422+ 0 -> B $ \s -> do
423+ putBackState s
424+ lbs <- B.getLazyByteString (fromIntegral n)
425+ return (S B.empty 0 bo, lbs)
426+ _ -> L.fromChunks . (:[]) <$> Data.Binary.Bits.Get.getByteString n
234427
235−type Failure r = String -> Get (Either String r)
236−type Success a r = S -> a -> Get (Either String r)
237428
238−instance Monad BitGet where
239− return x = C $ \s kf ks -> ks s x
240− fail str = C $ \s kf ks -> kf str
241− (C c) >>= f = C $ \s kf ks -> c s kf (\s' a -> runCont (f a) s' kf ks)
242429
243−instance Functor BitGet where
244− fmap f m = m >>= \a -> return (f a)
245430
246−instance Applicative BitGet where
247− pure x = return x
248− fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
249431
250−runBitGetSimple :: BitGet a -> Get a
251−runBitGetSimple bg = do
252− v <- runBitGet bg
253− case v of
254− Left err -> fail err
255− Right v -> return v
432+-- | A block that will be read with only one boundary check. Needs to know the
433+-- number of bits in advance.
434+data Block a = Block Int (S -> a)
256435
257−runBitGet :: BitGet a -> Get (Either String a)
258−runBitGet bg = do
259− let bs = B.empty -- initial state
260− v <- runCont bg (S bs 0) (\str -> return (Left str)) (\s a -> return (Right (s, a)))
261− case v of
262− Left err -> return (Left err)
263− Right ((S _bs' _n), x) -> do
264− return (Right x)
265−
266−-- | Make sure there are at lest @n@ bits.
267−ensureBits :: Int -> BitGet ()
268−ensureBits n = C $ \s kf ks ->
269− let loop (S bs o) | n <= (B.length bs * 8 - o) = ks (S bs o) ()
270− | otherwise = do
271− let currentBits = B.length bs * 8 - o
272− let byteCount = (n - currentBits + 7) `div` 8
273− bs' <- B.getByteString byteCount
274− -- should always be enough going once throguh the loop
275− loop (S (bs`append`bs') o)
276− in loop s
436+instance Functor Block where
437+ fmap f (Block i p) = Block i (\s -> f (p s))
277438
278−getBool :: BitGet Bool
279−getBool = ensureBits 1 >> modifyState readBool
439+instance Applicative Block where
440+ pure a = Block 0 (\_ -> a)
441+ (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))
442+ (Block i _) *> (Block j q) = Block (i+j) (q . incS i)
443+ (Block i p) <* (Block j _) = Block (i+j) p
280444
281−getWord8 :: Int -> BitGet Word8
282−getWord8 n = ensureBits n >> modifyState (flip readWord8 n)
445+-- | Get a block. Will be read with one single boundry check, and
446+-- therefore requires a statically known number of bits.
447+-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be',
448+-- 'byteString' and 'Applicative'.
449+block :: Block a -> BitGet a
450+block (Block i p) = do
451+ ensureBits i
452+ s <- getState
453+ putState $! (incS i s)
454+ return $! p s
283455
284−getWord16be :: Int -> BitGet Word16
285−getWord16be n = ensureBits n >> modifyState (flip readWord16be n)
456+-- | Read a 1 bit 'Bool'.
457+bool :: Block Bool
458+bool = Block 1 readBool
286459
287−getWord32be :: Int -> BitGet Word32
288−getWord32be n = ensureBits n >> modifyState (flip readWord32be n)
460+-- | Read a 1 bit 'Bool'.
461+bool# :: Block Int
462+bool# = Block 1 readBool#
289463
290−getWord64be :: Int -> BitGet Word64
291−getWord64be n = ensureBits n >> modifyState (flip readWord64be n)
464+-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
465+word8 :: Int -> Block Word8
466+word8 n = Block n (readWordChecked 8 n)
292467
293−getByteString :: Int -> BitGet ByteString
294−getByteString n = do
295− ensureBits (n*8)
296− -- drop the first byte if we've started to use it
297− modifyState $ \s@(S bs o) ->
298− let bs' | o == 0 = bs
299− | otherwise = B.tail bs
300− in B.take n bs' :*: S (B.drop n bs') 0
468+-- | Read @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
469+word16 :: Int -> Block Word16
470+word16 n = Block n (readWordChecked 16 n)
301471
302−getState :: BitGet S
303−getState = C $ \s kf ks -> ks s s
472+word16be :: Int -> Block Word16
473+word16be = word16
474+{-# DEPRECATED word16be "Use 'word16' instead" #-}
304475
305−putState :: S -> BitGet ()
306−putState s = C $ \_ kf ks -> ks s ()
476+-- | Read @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
477+word32 :: Int -> Block Word32
478+word32 n = Block n (readWordChecked 32 n)
307479
308−modifyState :: (S -> (T a S)) -> BitGet a
309−modifyState f = C $ \s kf ks -> case f s of
310− w :*: s' -> ks s' w
480+word32be :: Int -> Block Word32
481+word32be = word32
482+{-# DEPRECATED word32be "Use 'word32' instead" #-}
311483
312−------------------------------------------------------------------------
313−-- Unchecked shifts, from the package binary
314−
315−shiftl_w16 :: Word16 -> Int -> Word16
316−shiftl_w32 :: Word32 -> Int -> Word32
317−shiftl_w64 :: Word64 -> Int -> Word64
318−
319−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
320−shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
321−shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
322−shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
323−
324−shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
325−shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
326−shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
327−
328−
329−#if WORD_SIZE_IN_BITS < 64
330−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
331−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
332−
333−#if __GLASGOW_HASKELL__ <= 606
334−-- Exported by GHC.Word in GHC 6.8 and higher
335−foreign import ccall unsafe "stg_uncheckedShiftL64"
336− uncheckedShiftL64# :: Word64# -> Int# -> Word64#
337−foreign import ccall unsafe "stg_uncheckedShiftRL64"
338− uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
339−#endif
340−
341−#else
342−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
343−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
344−#endif
345−
346−#else
347−shiftl_w8 = shiftL
348−shiftl_w16 = shiftL
349−shiftl_w32 = shiftL
350−shiftl_w64 = shiftL
351−
352−shiftr_w8 = shiftR
353−shiftr_w16 = shiftR
354−shiftr_w32 = shiftR
355−shiftr_w64 = shiftR
356−#endif
357−
358−{-
359−data R a where
360− RBool :: R Bool
361− RWord8 :: Int -> R Word8
362− RWord16be :: Int -> R Word16
363− RWord32be :: Int -> R Word32
364− RByteString :: Int -> R ByteString
365− RThis :: a -> R a
366− RNextTo :: R a -> R b -> R (T a b)
367− RMap :: R b -> (b -> R a) -> R a
368− RMapPure :: R a -> (a -> b) -> R b
369− RList :: Int -> R a -> R [a]
370− RCheck :: R a -> (a -> Bool) -> String -> R a
371−
372−instance Functor R where
373− fmap f m = RMapPure m f
374−
375−instance Show (R a) where
376− show r = case r of
377− RBool -> "Bool"
378−
379−size_in_bits :: forall a. R a -- ^ The record
380− -> Int -- ^ Number of bits
381−size_in_bits r = case r of
382− RBool -> 1
383− RWord8 n -> min n 8
384− RWord16be n -> min n 16
385− RWord32be n -> min n 16
386− RByteString n -> 8 * n
387− RThis _ -> 0
388− RList n r -> n * size_in_bits r
389− RMap r _ -> size_in_bits r
390− RMapPure r _ -> size_in_bits r
391− RCheck r _ _ -> size_in_bits r
392− RNextTo a b -> size_in_bits a + size_in_bits b
393−
394−size_in_bytes :: forall a. R a
395− -> Int
396−size_in_bytes r = byte_offset (size_in_bits r + 7)
397−
398−get :: R a -> Get a
399−get r = do
400− bs <- getByteString (size_in_bytes r)
401− a :*: s <- getR (S bs 0) r
402− return a
484+-- | Read @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
485+word64 :: Int -> Block Word64
486+word64 n = Block n (readWordChecked 64 n)
403487
404−getR :: S -> R a -> Get (T a S)
405−getR s0 r = do
406− case r of
407− RBool -> return (readBool s0)
408− RWord8 n -> return (readWord8 s0 n)
409− RWord16be n -> return (readWord16be s0 n)
410− RWord32be n -> return (readWord32be s0 n)
411− RByteString n -> return (readByteString s0 n)
412− RThis x -> return (x :*: s0)
413− RNextTo a b -> do
414− t :*: s <- getR s0 a
415− u :*: s' <- getR s b
416− return (t:*:u:*:s')
417− RMap r p -> do
418− a :*: s@(S bs o) <- getR s0 r
419− let codepath = p a
420− required_bytes = byte_offset (size_in_bits r - o)
421− bs' <- getByteString required_bytes
422− getR (S (bs `append` bs') o) codepath
423− RMapPure r f -> do
424− a :*: s <- getR s0 r
425− return (f a :*: s)
426− RList n r ->
427− let loop 0 s acc = return (List.reverse acc :*: s)
428− loop m s acc = do
429− a :*: s' <- getR s r
430− loop (m-1) s' (a:acc)
431− in loop n s0 []
432− RCheck r c m -> do
433− a :*: s <- getR s0 r
434− if c a
435− then return (a :*: s)
436− else fail m
437−-}
488+word64be :: Int -> Block Word64
489+word64be = word64
490+{-# DEPRECATED word64be "Use 'word64' instead" #-}
438491
492+-- | Read @n@ bytes as a 'ByteString'.
493+byteString :: Int -> Block ByteString
494+byteString n | n > 0 = Block (n*8) (readByteString n)
495+ | otherwise = Block 0 (\_ -> B.empty)
439496