@@ -1,22 +1,25 @@
11{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
22
3−module Bits ( R(..)
3+module BitsGet
4+ ( R(..)
45 , T(..)
56 , get
6− , getS
7+ , getR
78 , readBool
89 , readWord8
910 , readWord16be
10− {-
1111 , runBitGet
1212 , BitGet
13− -}
13+ , getBool
14+ , getWord8
15+ , getWord16be
16+ , getWord32be
1417
1518 ) where
1619
17−import Data.Binary.Get
20+import Data.Binary.Get ( runGet, Get, needMore, getByteString, getS, putS )
1821
19−import Data.ByteString
22+import Data.ByteString as B
2023import Data.ByteString.Internal
2124import Data.ByteString.Unsafe
2225
@@ -26,6 +29,8 @@ import Data.Bits
2629import Data.Word
2730import Data.List as List ( reverse )
2831
32+import Control.Applicative
33+
2934#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
3035import GHC.Base hiding ( (:*:) )
3136import GHC.Word
@@ -47,10 +52,13 @@ data R a where
4752
4853data T a b = !a :*: !b deriving (Show)
4954
55+instance Functor R where
56+ fmap f m = RMapPure m f
57+
5058instance Show (R a) where
5159 show r = case r of
5260 RBool -> "Bool"
53−
61+
5462size_in_bits :: forall a. R a -- ^ The record
5563 -> Int -- ^ Number of bits
5664size_in_bits r = case r of
@@ -77,11 +85,11 @@ size_in_bytes r = byte_offset (size_in_bits r + 7)
7785get :: R a -> Get a
7886get r = do
7987 bs <- getByteString (size_in_bytes r)
80− a :*: s <- getS (S bs 0) r
88+ a :*: s <- getR (S bs 0) r
8189 return a
8290
83−getS :: S -> R a -> Get (T a S)
84−getS s0 r = do
91+getR :: S -> R a -> Get (T a S)
92+getR s0 r = do
8593 case r of
8694 RBool -> return (readBool s0)
8795 RWord8 n -> return (readWord8 s0 n)
@@ -90,26 +98,26 @@ getS s0 r = do
9098 RByteString n -> return (readByteString s0 n)
9199 RThis x -> return (x :*: s0)
92100 RNextTo a b -> do
93− t :*: s <- getS s0 a
94− u :*: s' <- getS s b
101+ t :*: s <- getR s0 a
102+ u :*: s' <- getR s b
95103 return (t:*:u:*:s')
96104 RMap r p -> do
97− a :*: s@(S bs o) <- getS s0 r
105+ a :*: s@(S bs o) <- getR s0 r
98106 let codepath = p a
99107 required_bytes = byte_offset (size_in_bits r - o)
100108 bs' <- getByteString required_bytes
101− getS (S (bs `append` bs') o) codepath
109+ getR (S (bs `append` bs') o) codepath
102110 RMapPure r f -> do
103− a :*: s <- getS s0 r
111+ a :*: s <- getR s0 r
104112 return (f a :*: s)
105113 RList n r ->
106114 let loop 0 s acc = return (List.reverse acc :*: s)
107115 loop m s acc = do
108− a :*: s' <- getS s r
116+ a :*: s' <- getR s r
109117 loop (m-1) s' (a:acc)
110118 in loop n s0 []
111119 RCheck r c m -> do
112− a :*: s <- getS s0 r
120+ a :*: s <- getR s0 r
113121 if c a
114122 then return (a :*: s)
115123 else fail m
@@ -198,9 +206,7 @@ readWord16be s@(S bs o) n
198206readWithoutOffset s@(S bs o) shifterL shifterR n
199207 | o /= 0 = error "readWithoutOffset: there is an offset"
200208
201− -- | n == 8 = readWord8 s n
202− -- | n == 16 = readWord16be s n
203− | n == 24 || n == 32 =
209+ | bit_offset n == 0 && byte_offset n <= 4 =
204210 let segs = byte_offset n
205211 bn 0 = fromIntegral (unsafeHead bs)
206212 bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
@@ -247,13 +253,27 @@ readWord32be s@(S bs o) n
247253 in fromIntegral w :*: s'
248254
249255 | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
250− -- error "readWord32be: can't read without offset..."
251256
252257 | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
253258
254259 | otherwise = error "readWord32be: tried to read more than 32 bits"
255260
256−{-
261+
262+readWord64be :: S -> Int -> T Word32 S
263+readWord64be s@(S bs o) n
264+ -- 8 or fewer bits, use readWord8
265+ | n <= 8 = let w :*: s' = readWord8 s n
266+ in fromIntegral w :*: s'
267+
268+ -- 16 or fewer bits, use readWord16be
269+ | n <= 16 = let w :*: s' = readWord16be s n
270+ in fromIntegral w :*: s'
271+
272+ | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
273+
274+ | n <= 64 = readWithOffset s shiftl_w32 shiftr_w32 n
275+
276+ | otherwise = error "readWord64be: tried to read more than 64 bits"
257277
258278------------------------------------------------------------------------
259279-- unrolled codensity/state monad
@@ -261,29 +281,57 @@ newtype BitGet a = C { runCont :: forall r.
261281 S ->
262282 Failure r ->
263283 Success a r ->
264− Either String r }
284+ Get (Either String r) }
265285
266−type Failure r = String -> Either String r
267−type Success a r = S -> a -> Either String r
286+type Failure r = String -> Get (Either String r)
287+type Success a r = S -> a -> Get (Either String r)
268288
269289instance Monad BitGet where
270290 return x = C $ \s kf ks -> ks s x
271291 fail str = C $ \s kf ks -> kf str
272292 (C c) >>= f = C $ \s kf ks -> c s kf (\s' a -> runCont (f a) s' kf ks)
273293
274−runBitGet :: BitGet a -> Int -> Get (Either String a)
275−runBitGet bg size = do
276− bs <- getByteString size
277− return $ runCont bg (S bs 0) (\str -> Left str) (\s a -> Right a)
294+instance Functor BitGet where
295+ fmap f m = m >>= \a -> return (f a)
296+
297+instance Applicative BitGet where
298+ pure x = return x
299+ fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
300+
301+runBitGet :: BitGet a -> Get (Either String a)
302+runBitGet bg = do
303+ bs <- getS -- get the current chunk
304+ putS B.empty
305+ v <- runCont bg (S bs 0) (\str -> return (Left str)) (\s a -> return (Right (s, a)))
306+ case v of
307+ Left err -> return (Left err)
308+ Right ((S bs' n), x) -> do
309+ let bs'' | n > 0 = B.tail bs'
310+ | otherwise = bs'
311+ putS bs''
312+ return (Right x)
313+
314+ensure :: Int -> BitGet ()
315+ensure n = C $ \s kf ks ->
316+ let loop (S bs o) | n <= (B.length bs * 8 - o) = ks (S bs o) ()
317+ | otherwise = do
318+ needMore
319+ bs' <- getS
320+ putS B.empty
321+ loop (S (bs`append`bs') o)
322+ in loop s
323+
324+getBool :: BitGet Bool
325+getBool = ensure 1 >> modifyState readBool
278326
279327getWord8 :: Int -> BitGet Word8
280−getWord8 = modifyState . flip readWord8
328+getWord8 n = ensure n >> modifyState (flip readWord8 n)
281329
282330getWord16be :: Int -> BitGet Word16
283−getWord16be = modifyState . flip readWord16be
331+getWord16be n = ensure n >> modifyState (flip readWord16be n)
284332
285333getWord32be :: Int -> BitGet Word32
286−getWord32be = modifyState . flip readWord32be
334+getWord32be n = ensure n >> modifyState (flip readWord32be n)
287335
288336getState :: BitGet S
289337getState = C $ \s kf ks -> ks s s
@@ -294,7 +342,6 @@ putState s = C $ \_ kf ks -> ks s ()
294342modifyState :: (S -> (T a S)) -> BitGet a
295343modifyState f = C $ \s kf ks -> case f s of
296344 w :*: s' -> ks s' w
297−-}
298345
299346------------------------------------------------------------------------
300347-- Unchecked shifts, from the package binary