@@ -1,39 +1,93 @@
1{-# LANGUAGE RankNTypes, MagicHash, BangPatterns, CPP #-}
1{-# LANGUAGE RankNTypes, MagicHash, BangPatterns, CPP #-}
3+-----------------------------------------------------------------------------
5+-- Module : Data.Binary.Bits.Get
6+-- Copyright : (c) Lennart Kolmodin 2010-2011
7+-- License : BSD3-style (see LICENSE)
9+-- Maintainer : kolmodin@gmail.com
10+-- Stability : experimental
11+-- Portability : portable (should run where the package binary runs)
13+-- Parse bits easily. Parsing can be done either in a monadic style, or more
14+-- efficiently, using the 'Applicative' style.
16+-- For the monadic style, write your parser as a 'BitGet' monad using the
30+-- functions and run it with 'runBitGet'.
32+-- For the applicative style, compose the fuctions
47+-- Use 'block' to turn it into the 'BitGet' monad to be able to run it with
49+-----------------------------------------------------------------------------
3module Data.Binary.Bits.Get
51module Data.Binary.Bits.Get
4− ( BitGet
53+ -- * BitGet monad
6 , runBitGet
58 , runBitGet
9 , getWord8
62 , getWord8
10 , getWord16be
63 , getWord16be
11 , getWord32be
64 , getWord32be
12 , getWord64be
65 , getWord64be
16 , word16be
76 , word16be
17 , word32be
77 , word32be
18 , word64be
78 , word64be
19 , byteString
79 , byteString
23 , Data.Binary.Bits.Get.getByteString
80 , Data.Binary.Bits.Get.getByteString
26import Data.Binary.Get as B ( runGet, Get, getByteString )
84import Data.Binary.Get as B ( runGet, Get, getByteString )
28import Data.ByteString as B
86import Data.ByteString as B
29−import Data.ByteString.Internal
30import Data.ByteString.Unsafe
87import Data.ByteString.Unsafe
32−import qualified Data.ByteString.Lazy as L
34import Data.Bits
89import Data.Bits
35import Data.Word
90import Data.Word
36−import Data.List as List ( reverse )
38import Control.Applicative
92import Control.Applicative
@@ -42,32 +96,31 @@ import Prelude as P
42#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
96#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
43import GHC.Base
97import GHC.Base
44import GHC.Word
98import GHC.Word
48−data S = S !ByteString -- Input
49− !Int -- Bit offset (0-7)
52−-- | A block that will be read with only one boundry check. Needs to know the
53−-- number of bits in advance.
54−data Block a = Block !Int (S -> a)
56−instance Functor Block where
102+-- $bitget
57− fmap f (Block i p) = Block i (\s -> f (p s))
103+-- Parse bits using a monad.
59−instance Applicative Block where
105+-- @
60− pure a = Block 0 (\_ -> a)
106+--myBitParser :: 'Get' ('Word8', 'Word8')
61− (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))
107+--myBitParser = 'runGetBit' parse4by4
62− (Block i _) *> (Block j q) = Block (i+j) (q . incS i)
63− (Block i p) <* (Block j _) = Block (i+j) p
65−-- | Get a block. Guaranteed to be done with one single boundry check, and must
66−-- therefore require a statically known number of bits.
67−-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be' and 'Applicative'.
109+--parse4by4 :: 'BitGet' ('Word8', 'Word8')
111+-- bits <- 'getWord8' 4
112+-- more <- 'getWord8' 4
113+-- return (bits,more)
117+-- Parse more efficiently in blocks. Each block is read with only one boundry
118+-- check (checking that there is enough input) as the size of the block can be
119+-- calculated statically. This is somewhat limiting as you cannot make the
120+-- parsing depend on the input being parsed.
70−-- data IPV6Header = IPV6Header {
123+--data IPV6Header = IPV6Header {
71-- ipv6Version :: 'Word8'
124-- ipv6Version :: 'Word8'
72-- , ipv6TrafficClass :: 'Word8'
125-- , ipv6TrafficClass :: 'Word8'
73-- , ipv6FlowLabel :: 'Word32
126-- , ipv6FlowLabel :: 'Word32
@@ -78,7 +131,8 @@ instance Applicative Block where
78-- , ipv6DestinationAddress :: 'ByteString'
131-- , ipv6DestinationAddress :: 'ByteString'
81−-- parse = IPV6Header '<$>' 'word8' 4
135+-- IPV6Header '<$>' 'word8' 4
82-- '<*>' 'word8' 8
136-- '<*>' 'word8' 8
83-- '<*>' 'word32be' 24
137-- '<*>' 'word32be' 24
84-- '<*>' 'word16be' 16
138-- '<*>' 'word16be' 16
@@ -86,12 +140,45 @@ instance Applicative Block where
86-- '<*>' 'word8' 8
140-- '<*>' 'word8' 8
87-- '<*>' 'byteString' 16
141-- '<*>' 'byteString' 16
88-- '<*>' 'byteString' 16
142-- '<*>' 'byteString' 16
144+--ipv6Header :: 'Get' IPV6Header
145+--ipv6Header = 'runBitGet' ('block' ipv6headerblock)
148+data S = S !ByteString -- Input
149+ !Int -- Bit offset (0-7)
152+-- | A block that will be read with only one boundry check. Needs to know the
153+-- number of bits in advance.
154+data Block a = Block !Int (S -> a)
156+instance Functor Block where
157+ fmap f (Block i p) = Block i (\s -> f (p s))
159+instance Applicative Block where
160+ pure a = Block 0 (\_ -> a)
161+ (Block i p) <*> (Block j q) = Block (i+j) (\s -> p s $ q (incS i s))
162+ (Block i _) *> (Block j q) = Block (i+j) (q . incS i)
163+ (Block i p) <* (Block j _) = Block (i+j) p
165+-- | Get a block. Will be read with one single boundry check, and
166+-- therefore requires a statically known number of bits.
167+-- Build blocks using 'bool', 'word8', 'word16be', 'word32be', 'word64be',
168+-- 'byteString' and 'Applicative'.
90block :: Block a -> BitGet a
169block :: Block a -> BitGet a
91block (Block i p) = do
170block (Block i p) = do
92 ensureBits i
171 ensureBits i
93 modifyState (\s -> (incS i s, p s))
172 modifyState (\s -> (incS i s, p s))
175+incS :: Int -> S -> S
179+ !n' = o' .&. make_mask 3
180+ in S (unsafeDrop d bs) n'
95-- | make_mask 3 = 00000111
182-- | make_mask 3 = 00000111
96make_mask :: Bits a => Int -> a
183make_mask :: Bits a => Int -> a
97make_mask n = (1 `shiftL` fromIntegral n) - 1
184make_mask n = (1 `shiftL` fromIntegral n) - 1
@@ -102,25 +189,17 @@ make_mask n = (1 `shiftL` fromIntegral n) - 1
102{-# SPECIALIZE make_mask :: Int -> Word32 #-}
189{-# SPECIALIZE make_mask :: Int -> Word32 #-}
103{-# SPECIALIZE make_mask :: Int -> Word64 #-}
190{-# SPECIALIZE make_mask :: Int -> Word64 #-}
105−readBool :: S -> Bool
192+bit_offset :: Int -> Int
106−readBool (S bs n) = testBit (unsafeHead bs) (7-n)
193+bit_offset n = make_mask 3 .&. n
108−incS :: Int -> S -> S
195+byte_offset :: Int -> Int
111− !d = o' `shiftR` 3
196+byte_offset n = n `shiftR` 3
112− !n' = o' .&. make_mask 3
113− in S (unsafeDrop d bs) n'
115−readByteString :: Int -> S -> ByteString
198+readBool :: S -> Bool
116−readByteString n s@(S bs o)
199+readBool (S bs n) = testBit (unsafeHead bs) (7-n)
118− | o == 0 = unsafeTake n bs
119− -- offset. ugg. this is really naive and slow. but also pretty easy :)
120− | otherwise = B.pack (P.map (readWord8 8) (P.take n (iterate (incS 8) s)))
122readWord8 :: Int -> S -> Word8
201readWord8 :: Int -> S -> Word8
123−readWord8 n s@(S bs o)
202+readWord8 n (S bs o)
124 -- no bits at all, return 0
203 -- no bits at all, return 0
125 | n == 0 = 0
204 | n == 0 = 0
@@ -139,11 +218,6 @@ readWord8 n s@(S bs o)
139 w' = (w `shiftr_w16` (16 - o - n)) .&. m
218 w' = (w `shiftr_w16` (16 - o - n)) .&. m
140 in fromIntegral w'
219 in fromIntegral w'
142−bit_offset :: Int -> Int
143−bit_offset n = make_mask 3 .&. n
145−byte_offset :: Int -> Int
146−byte_offset n = n `shiftR` 3
148readWord16be :: Int -> S -> Word16
222readWord16be :: Int -> S -> Word16
149readWord16be n s@(S bs o)
223readWord16be n s@(S bs o)
@@ -170,9 +244,46 @@ readWord16be n s@(S bs o)
171 | otherwise = error "readWord16be: tried to read more than 16 bits"
245 | otherwise = error "readWord16be: tried to read more than 16 bits"
247+readWord32be :: Int -> S -> Word32
248+readWord32be n s@(S _ o)
249+ -- 8 or fewer bits, use readWord8
250+ | n <= 8 = fromIntegral (readWord8 n s)
252+ -- 16 or fewer bits, use readWord16be
253+ | n <= 16 = fromIntegral (readWord16be n s)
255+ | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
257+ | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
259+ | otherwise = error "readWord32be: tried to read more than 32 bits"
262+readWord64be :: Int -> S -> Word64
263+readWord64be n s@(S _ o)
264+ -- 8 or fewer bits, use readWord8
265+ | n <= 8 = fromIntegral (readWord8 n s)
267+ -- 16 or fewer bits, use readWord16be
268+ | n <= 16 = fromIntegral (readWord16be n s)
270+ | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n
272+ | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n
274+ | otherwise = error "readWord64be: tried to read more than 64 bits"
277+readByteString :: Int -> S -> ByteString
278+readByteString n s@(S bs o)
280+ | o == 0 = unsafeTake n bs
281+ -- offset. ugg. this is really naive and slow. but also pretty easy :)
282+ | otherwise = B.pack (P.map (readWord8 8) (P.take n (iterate (incS 8) s)))
173readWithoutOffset :: (Bits a, Num a)
284readWithoutOffset :: (Bits a, Num a)
174 => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
285 => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
175−readWithoutOffset s@(S bs o) shifterL shifterR n
286+readWithoutOffset (S bs o) shifterL shifterR n
176 | o /= 0 = error "readWithoutOffset: there is an offset"
287 | o /= 0 = error "readWithoutOffset: there is an offset"
178 | bit_offset n == 0 && byte_offset n <= 4 =
289 | bit_offset n == 0 && byte_offset n <= 4 =
@@ -196,8 +307,8 @@ readWithoutOffset s@(S bs o) shifterL shifterR n
198readWithOffset :: (Bits a, Num a)
309readWithOffset :: (Bits a, Num a)
199− => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
310+ => S -> (a -> Int -> a) -> (a -> Int -> a) -> Int -> a
200−readWithOffset s@(S bs o) shifterL shifterR n
311+readWithOffset (S bs o) shifterL shifterR n
201 | n <= 64 = let bits_in_msb = 8 - o
312 | n <= 64 = let bits_in_msb = 8 - o
202 (n',top) = (n - bits_in_msb
313 (n',top) = (n - bits_in_msb
203 , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')
314 , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')
@@ -217,38 +328,9 @@ readWithOffset s@(S bs o) shifterL shifterR n
217 w = top .|. mseg .|. last
328 w = top .|. mseg .|. last
221−readWord32be :: Int -> S -> Word32
222−readWord32be n s@(S bs o)
223− -- 8 or fewer bits, use readWord8
224− | n <= 8 = fromIntegral (readWord8 n s)
226− -- 16 or fewer bits, use readWord16be
227− | n <= 16 = fromIntegral (readWord16be n s)
229− | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
231− | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
233− | otherwise = error "readWord32be: tried to read more than 32 bits"
236−readWord64be :: Int -> S -> Word64
237−readWord64be n s@(S bs o)
238− -- 8 or fewer bits, use readWord8
239− | n <= 8 = fromIntegral (readWord8 n s)
241− -- 16 or fewer bits, use readWord16be
242− | n <= 16 = fromIntegral (readWord16be n s)
244− | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n
246− | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n
248− | otherwise = error "readWord64be: tried to read more than 64 bits"
250------------------------------------------------------------------------
331------------------------------------------------------------------------
251−
332+-- | 'BitGet' is a monad, applicative and a functor. See 'runBitGet'
333+-- for how to run it.
252newtype BitGet a = B { runState :: S -> Get (S,a) }
334newtype BitGet a = B { runState :: S -> Get (S,a) }
254instance Monad BitGet where
336instance Monad BitGet where
@@ -264,6 +346,8 @@ instance Applicative BitGet where
264 pure x = return x
346 pure x = return x
265 fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
347 fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
349+-- | Run a 'BitGet' within the Binary packages 'Get' monad. If a byte has
350+-- been partially consumed it will be discarded once 'runBitGet' is finished.
267runBitGet :: BitGet a -> Get a
351runBitGet :: BitGet a -> Get a
268runBitGet bg = do
352runBitGet bg = do
269 (_,a) <- runState bg (S B.empty 0)
353 (_,a) <- runState bg (S B.empty 0)
@@ -281,47 +365,59 @@ modifyState f = B $ \s -> return (f s)
281-- | Make sure there are at least @n@ bits.
365-- | Make sure there are at least @n@ bits.
282ensureBits :: Int -> BitGet ()
366ensureBits :: Int -> BitGet ()
283ensureBits n = do
367ensureBits n = do
284− s@(S bs o) <- getState
368+ (S bs o) <- getState
285 if n <= (B.length bs * 8 - o)
369 if n <= (B.length bs * 8 - o)
286 then return ()
370 then return ()
287 else do let currentBits = B.length bs * 8 - o
371 else do let currentBits = B.length bs * 8 - o
288 let byteCount = (n - currentBits + 7) `div` 8
372 let byteCount = (n - currentBits + 7) `div` 8
289− B $ \s -> do bs' <- B.getByteString byteCount
373+ B $ \_ -> do bs' <- B.getByteString byteCount
290 return (S (bs`append`bs') o, ())
374 return (S (bs`append`bs') o, ())
376+-- | Get 1 bit as a 'Bool'.
292getBool :: BitGet Bool
377getBool :: BitGet Bool
293getBool = block bool
378getBool = block bool
380+-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
295getWord8 :: Int -> BitGet Word8
381getWord8 :: Int -> BitGet Word8
296getWord8 n = block (word8 n)
382getWord8 n = block (word8 n)
384+-- | Get @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
298getWord16be :: Int -> BitGet Word16
385getWord16be :: Int -> BitGet Word16
299getWord16be n = block (word16be n)
386getWord16be n = block (word16be n)
388+-- | Get @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
301getWord32be :: Int -> BitGet Word32
389getWord32be :: Int -> BitGet Word32
302getWord32be n = block (word32be n)
390getWord32be n = block (word32be n)
392+-- | Get @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
304getWord64be :: Int -> BitGet Word64
393getWord64be :: Int -> BitGet Word64
305getWord64be n = block (word64be n)
394getWord64be n = block (word64be n)
396+-- | Get @n@ bytes as a 'ByteString'.
307getByteString :: Int -> BitGet ByteString
397getByteString :: Int -> BitGet ByteString
308getByteString n = block (byteString n)
398getByteString n = block (byteString n)
400+-- | Read a 1 bit 'Bool'.
310bool :: Block Bool
401bool :: Block Bool
311bool = Block 1 readBool
402bool = Block 1 readBool
404+-- | Read @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
313word8 :: Int -> Block Word8
405word8 :: Int -> Block Word8
314word8 n = Block n (readWord8 n)
406word8 n = Block n (readWord8 n)
408+-- | Read @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
316word16be :: Int -> Block Word16
409word16be :: Int -> Block Word16
317word16be n = Block n (readWord16be n)
410word16be n = Block n (readWord16be n)
412+-- | Read @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
319word32be :: Int -> Block Word32
413word32be :: Int -> Block Word32
320word32be n = Block n (readWord32be n)
414word32be n = Block n (readWord32be n)
416+-- | Read @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
322word64be :: Int -> Block Word64
417word64be :: Int -> Block Word64
323word64be n = Block n (readWord64be n)
418word64be n = Block n (readWord64be n)
420+-- | Read @n@ bytes as a 'ByteString'.
325byteString :: Int -> Block ByteString
421byteString :: Int -> Block ByteString
326byteString n = Block (n*8) (readByteString n)
422byteString n = Block (n*8) (readByteString n)