@@ -1,496 +1,441 @@
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−-----------------------------------------------------------------------------
1+{-# LANGUAGE RankNTypes, MagicHash, CPP #-}
512
523module Data.Binary.Bits.Get
53− (
54− -- * BitGet monad
55−
56− -- $bitget
57−
58− BitGet
4+ ( T(..)
595 , runBitGet
6+ , runBitGetSimple
7+ , BitGet
8+ -- , joinGet
609
61− -- ** Get bytes
6210 , getBool
63− , getBool#
6411 , getWord8
65− , getWord16
66− , getWord32
67− , getWord64
6812 , getWord16be
6913 , getWord32be
7014 , getWord64be
7115
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
9216 , Data.Binary.Bits.Get.getByteString
93− , Data.Binary.Bits.Get.getLazyByteString
94− , Data.Binary.Bits.Get.isEmpty
17+
18+ , readBool
19+ , readWord8
20+ , readWord16be
9521
9622 ) where
9723
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
24+import Data.Binary.Get as B ( runGet, Get, getByteString )
10325
10426import Data.ByteString as B
105−import qualified Data.ByteString.Lazy as L
27+import Data.ByteString.Internal
10628import Data.ByteString.Unsafe
107−import Foreign.Marshal.Alloc (mallocBytes)
108−import Foreign.Ptr
109−import Foreign.Storable (poke)
110−import System.IO.Unsafe (unsafePerformIO)
29+
30+import qualified Data.ByteString.Lazy as L
11131
11232import Data.Bits
11333import Data.Word
34+import Data.List as List ( reverse )
35+
11436import Control.Applicative
115−import Control.Monad (when,foldM_)
11637
117−import Prelude as P
38+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
39+import GHC.Base hiding ( (:*:) )
11840import GHC.Word
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
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)
17048 deriving (Show)
17149
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)
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)
28192
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
282104
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) }
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
287112
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'
113+bit_offset :: Int -> Int
114+bit_offset n = make_mask 3 .&. n
292115
293−instance Functor BitGet where
294− fmap f m = m >>= \a -> return (f a)
116+byte_offset :: Int -> Int
117+byte_offset n = n `shiftR` 3
295118
296−instance Applicative BitGet where
297− pure x = return x
298− fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
119+readWord16be :: S -> Int -> T Word16 S
120+readWord16be s@(S bs o) n
299121
300−instance BitOrderable BitGet where
301− setBitOrder bo = do
302− (S bs o _) <- getState
303− putState (S bs o bo)
122+ -- 8 or fewer bits, use readWord8
123+ | n <= 8 = let w :*: s' = readWord8 s n
124+ in fromIntegral w :*: s'
304125
305− getBitOrder = do
306− (S _ _ bo) <- getState
307− return bo
126+ -- handle 9 or more bits, stored in two bytes
308127
309−instance Alignable BitGet where
310− -- | Skip the given number of bits
311− skipBits n = do
312− ensureBits n
313− withState (incS n)
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
314133
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)
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
320139
140+ -- with offset, and n=9-16
141+ | n <= 16 = readWithOffset s shiftl_w16 shiftr_w16 n
321142
143+ | otherwise = error "readWord16be: tried to read more than 16 bits"
322144
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
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"
331149
332−mkInitState :: Get S
333−mkInitState = do
334− bs <- get
335− put B.empty
336− return (S bs 0 BB)
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)
337154
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)
155+ in (bn (segs-1) :*: incS s n)
345156
346−getState :: BitGet S
347−getState = B $ \s -> return (s,s)
157+ | n <= 64 = let segs = byte_offset n
158+ o' = bit_offset (n - 8 + o)
348159
349−putState :: S -> BitGet ()
350−putState s = B $ \_ -> return (s,())
160+ bn 0 = fromIntegral (unsafeHead bs)
161+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
351162
352−withState :: (S -> S) -> BitGet ()
353−withState f = do
354− s <- getState
355− putState $! f s
163+ msegs = bn (segs-1) `shifterL` o'
356164
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
165+ last = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')
380166
381−-- | Get 1 bit as a 'Bool'.
382−getBool# :: BitGet Int
383−getBool# = block bool#
167+ w = msegs .|. last
168+ in w :*: incS s n
384169
385−-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
386−getWord8 :: Int -> BitGet Word8
387−getWord8 n = block (word8 n)
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'
388178
389−-- | Get @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
390−getWord16 :: Int -> BitGet Word16
391−getWord16 n = block (word16 n)
179+ bn 0 = 0
180+ bn 1 = fromIntegral (unsafeIndex bs 1)
181+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
392182
393−getWord16be :: Int -> BitGet Word16
394−getWord16be = getWord16
395−{-# DEPRECATED getWord16be "Use 'getWord16' instead" #-}
183+ o' = bit_offset n'
396184
397−-- | Get @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
398−getWord32 :: Int -> BitGet Word32
399−getWord32 n = block (word32 n)
185+ mseg = bn segs `shifterL` o'
400186
401−getWord32be :: Int -> BitGet Word32
402−getWord32be = getWord32
403−{-# DEPRECATED getWord32be "Use 'getWord32' instead" #-}
187+ last | o' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shifterR` (8 - o')
188+ | otherwise = 0
404189
405−-- | Get @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
406−getWord64 :: Int -> BitGet Word64
407−getWord64 n = block (word64 n)
190+ w = top .|. mseg .|. last
191+ in w :*: incS s n
408192
409−getWord64be :: Int -> BitGet Word64
410−getWord64be = getWord64
411−{-# DEPRECATED getWord64be "Use 'getWord64' instead" #-}
412193
413−-- | Get @n@ bytes as a 'ByteString'.
414−getByteString :: Int -> BitGet ByteString
415−getByteString n = block (byteString n)
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'
416199
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
200+ -- 16 or fewer bits, use readWord16be
201+ | n <= 16 = let w :*: s' = readWord16be s n
202+ in fromIntegral w :*: s'
427203
204+ | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
428205
206+ | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
429207
208+ | otherwise = error "readWord32be: tried to read more than 32 bits"
430209
431210
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)
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'
435216
436−instance Functor Block where
437− fmap f (Block i p) = Block i (\s -> f (p s))
217+ -- 16 or fewer bits, use readWord16be
218+ | n <= 16 = let w :*: s' = readWord16be s n
219+ in fromIntegral w :*: s'
438220
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
221+ | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n
444222
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
223+ | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n
455224
456−-- | Read a 1 bit 'Bool'.
457−bool :: Block Bool
458−bool = Block 1 readBool
225+ | otherwise = error "readWord64be: tried to read more than 64 bits"
459226
460−-- | Read a 1 bit 'Bool'.
461−bool# :: Block Int
462−bool# = Block 1 readBool#
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) }
463234
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)
235+type Failure r = String -> Get (Either String r)
236+type Success a r = S -> a -> Get (Either String r)
467237
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)
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)
471242
472−word16be :: Int -> Block Word16
473−word16be = word16
474−{-# DEPRECATED word16be "Use 'word16' instead" #-}
243+instance Functor BitGet where
244+ fmap f m = m >>= \a -> return (f a)
475245
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)
246+instance Applicative BitGet where
247+ pure x = return x
248+ fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
479249
480−word32be :: Int -> Block Word32
481−word32be = word32
482−{-# DEPRECATED word32be "Use 'word32' instead" #-}
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
483256
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)
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
277+
278+getBool :: BitGet Bool
279+getBool = ensureBits 1 >> modifyState readBool
280+
281+getWord8 :: Int -> BitGet Word8
282+getWord8 n = ensureBits n >> modifyState (flip readWord8 n)
283+
284+getWord16be :: Int -> BitGet Word16
285+getWord16be n = ensureBits n >> modifyState (flip readWord16be n)
286+
287+getWord32be :: Int -> BitGet Word32
288+getWord32be n = ensureBits n >> modifyState (flip readWord32be n)
289+
290+getWord64be :: Int -> BitGet Word64
291+getWord64be n = ensureBits n >> modifyState (flip readWord64be n)
292+
293+-- | Get a @ByteString@. Drops the current byte if we've started to read
294+-- from it.
295+getByteString :: Int -> BitGet ByteString
296+getByteString n = do
297+ ensureBits (n*8)
298+ -- drop the first byte if we've started to use it
299+ modifyState $ \s@(S bs o) ->
300+ let bs' | o == 0 = bs
301+ | otherwise = B.tail bs
302+ in B.take n bs' :*: S (B.drop n bs') 0
303+
304+getState :: BitGet S
305+getState = C $ \s kf ks -> ks s s
306+
307+putState :: S -> BitGet ()
308+putState s = C $ \_ kf ks -> ks s ()
309+
310+modifyState :: (S -> (T a S)) -> BitGet a
311+modifyState f = C $ \s kf ks -> case f s of
312+ w :*: s' -> ks s' w
313+
314+------------------------------------------------------------------------
315+-- Unchecked shifts, from the package binary
316+
317+shiftl_w16 :: Word16 -> Int -> Word16
318+shiftl_w32 :: Word32 -> Int -> Word32
319+shiftl_w64 :: Word64 -> Int -> Word64
320+
321+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
322+shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
323+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
324+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
325+
326+shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
327+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
328+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
329+
330+
331+#if WORD_SIZE_IN_BITS < 64
332+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
333+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
334+
335+#if __GLASGOW_HASKELL__ <= 606
336+-- Exported by GHC.Word in GHC 6.8 and higher
337+foreign import ccall unsafe "stg_uncheckedShiftL64"
338+ uncheckedShiftL64# :: Word64# -> Int# -> Word64#
339+foreign import ccall unsafe "stg_uncheckedShiftRL64"
340+ uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
341+#endif
342+
343+#else
344+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
345+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
346+#endif
347+
348+#else
349+shiftl_w8 = shiftL
350+shiftl_w16 = shiftL
351+shiftl_w32 = shiftL
352+shiftl_w64 = shiftL
353+
354+shiftr_w8 = shiftR
355+shiftr_w16 = shiftR
356+shiftr_w32 = shiftR
357+shiftr_w64 = shiftR
358+#endif
359+
360+{-
361+data R a where
362+ RBool :: R Bool
363+ RWord8 :: Int -> R Word8
364+ RWord16be :: Int -> R Word16
365+ RWord32be :: Int -> R Word32
366+ RByteString :: Int -> R ByteString
367+ RThis :: a -> R a
368+ RNextTo :: R a -> R b -> R (T a b)
369+ RMap :: R b -> (b -> R a) -> R a
370+ RMapPure :: R a -> (a -> b) -> R b
371+ RList :: Int -> R a -> R [a]
372+ RCheck :: R a -> (a -> Bool) -> String -> R a
373+
374+instance Functor R where
375+ fmap f m = RMapPure m f
376+
377+instance Show (R a) where
378+ show r = case r of
379+ RBool -> "Bool"
380+
381+size_in_bits :: forall a. R a -- ^ The record
382+ -> Int -- ^ Number of bits
383+size_in_bits r = case r of
384+ RBool -> 1
385+ RWord8 n -> min n 8
386+ RWord16be n -> min n 16
387+ RWord32be n -> min n 16
388+ RByteString n -> 8 * n
389+ RThis _ -> 0
390+ RList n r -> n * size_in_bits r
391+ RMap r _ -> size_in_bits r
392+ RMapPure r _ -> size_in_bits r
393+ RCheck r _ _ -> size_in_bits r
394+ RNextTo a b -> size_in_bits a + size_in_bits b
395+
396+size_in_bytes :: forall a. R a
397+ -> Int
398+size_in_bytes r = byte_offset (size_in_bits r + 7)
399+
400+get :: R a -> Get a
401+get r = do
402+ bs <- getByteString (size_in_bytes r)
403+ a :*: s <- getR (S bs 0) r
404+ return a
487405
488−word64be :: Int -> Block Word64
489−word64be = word64
490−{-# DEPRECATED word64be "Use 'word64' instead" #-}
406+getR :: S -> R a -> Get (T a S)
407+getR s0 r = do
408+ case r of
409+ RBool -> return (readBool s0)
410+ RWord8 n -> return (readWord8 s0 n)
411+ RWord16be n -> return (readWord16be s0 n)
412+ RWord32be n -> return (readWord32be s0 n)
413+ RByteString n -> return (readByteString s0 n)
414+ RThis x -> return (x :*: s0)
415+ RNextTo a b -> do
416+ t :*: s <- getR s0 a
417+ u :*: s' <- getR s b
418+ return (t:*:u:*:s')
419+ RMap r p -> do
420+ a :*: s@(S bs o) <- getR s0 r
421+ let codepath = p a
422+ required_bytes = byte_offset (size_in_bits r - o)
423+ bs' <- getByteString required_bytes
424+ getR (S (bs `append` bs') o) codepath
425+ RMapPure r f -> do
426+ a :*: s <- getR s0 r
427+ return (f a :*: s)
428+ RList n r ->
429+ let loop 0 s acc = return (List.reverse acc :*: s)
430+ loop m s acc = do
431+ a :*: s' <- getR s r
432+ loop (m-1) s' (a:acc)
433+ in loop n s0 []
434+ RCheck r c m -> do
435+ a :*: s <- getR s0 r
436+ if c a
437+ then return (a :*: s)
438+ else fail m
439+-}
491440
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)
496441