git.iko.soy/binary-bits
on master help sign in
Continue on the BitGet monad, and implement readWord64be
8897b89Lennart Kolmodin
Bits.hs → BitsGet.hsrenamed+80−33
compare with master
unifiedsplit
@@ -1,22 +1,25 @@
1{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
1{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
2
2
3−module Bits ( R(..)
3+module BitsGet
4+ ( R(..)
4 , T(..)
5 , T(..)
5 , get
6 , get
6− , getS
7+ , getR
7 , readBool
8 , readBool
8 , readWord8
9 , readWord8
9 , readWord16be
10 , readWord16be
10− {-
11 , runBitGet
11 , runBitGet
12 , BitGet
12 , BitGet
13− -}
13+ , getBool
14+ , getWord8
15+ , getWord16be
16+ , getWord32be
14
17
15 ) where
18 ) where
16
19
17−import Data.Binary.Get
20+import Data.Binary.Get ( runGet, Get, needMore, getByteString, getS, putS )
18
21
19−import Data.ByteString
22+import Data.ByteString as B
20import Data.ByteString.Internal
23import Data.ByteString.Internal
21import Data.ByteString.Unsafe
24import Data.ByteString.Unsafe
22
25
@@ -26,6 +29,8 @@ import Data.Bits
26import Data.Word
29import Data.Word
27import Data.List as List ( reverse )
30import Data.List as List ( reverse )
28
31
32+import Control.Applicative
33+
29#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
34#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
30import GHC.Base hiding ( (:*:) )
35import GHC.Base hiding ( (:*:) )
31import GHC.Word
36import GHC.Word
@@ -47,10 +52,13 @@ data R a where
47
52
48data T a b = !a :*: !b deriving (Show)
53data T a b = !a :*: !b deriving (Show)
49
54
55+instance Functor R where
56+ fmap f m = RMapPure m f
57+
50instance Show (R a) where
58instance Show (R a) where
51 show r = case r of
59 show r = case r of
52 RBool -> "Bool"
60 RBool -> "Bool"
53−
61+
54size_in_bits :: forall a. R a -- ^ The record
62size_in_bits :: forall a. R a -- ^ The record
55 -> Int -- ^ Number of bits
63 -> Int -- ^ Number of bits
56size_in_bits r = case r of
64size_in_bits r = case r of
@@ -77,11 +85,11 @@ size_in_bytes r = byte_offset (size_in_bits r + 7)
77get :: R a -> Get a
85get :: R a -> Get a
78get r = do
86get r = do
79 bs <- getByteString (size_in_bytes r)
87 bs <- getByteString (size_in_bytes r)
80− a :*: s <- getS (S bs 0) r
88+ a :*: s <- getR (S bs 0) r
81 return a
89 return a
82
90
83−getS :: S -> R a -> Get (T a S)
91+getR :: S -> R a -> Get (T a S)
84−getS s0 r = do
92+getR s0 r = do
85 case r of
93 case r of
86 RBool -> return (readBool s0)
94 RBool -> return (readBool s0)
87 RWord8 n -> return (readWord8 s0 n)
95 RWord8 n -> return (readWord8 s0 n)
@@ -90,26 +98,26 @@ getS s0 r = do
90 RByteString n -> return (readByteString s0 n)
98 RByteString n -> return (readByteString s0 n)
91 RThis x -> return (x :*: s0)
99 RThis x -> return (x :*: s0)
92 RNextTo a b -> do
100 RNextTo a b -> do
93− t :*: s <- getS s0 a
101+ t :*: s <- getR s0 a
94− u :*: s' <- getS s b
102+ u :*: s' <- getR s b
95 return (t:*:u:*:s')
103 return (t:*:u:*:s')
96 RMap r p -> do
104 RMap r p -> do
97− a :*: s@(S bs o) <- getS s0 r
105+ a :*: s@(S bs o) <- getR s0 r
98 let codepath = p a
106 let codepath = p a
99 required_bytes = byte_offset (size_in_bits r - o)
107 required_bytes = byte_offset (size_in_bits r - o)
100 bs' <- getByteString required_bytes
108 bs' <- getByteString required_bytes
101− getS (S (bs `append` bs') o) codepath
109+ getR (S (bs `append` bs') o) codepath
102 RMapPure r f -> do
110 RMapPure r f -> do
103− a :*: s <- getS s0 r
111+ a :*: s <- getR s0 r
104 return (f a :*: s)
112 return (f a :*: s)
105 RList n r ->
113 RList n r ->
106 let loop 0 s acc = return (List.reverse acc :*: s)
114 let loop 0 s acc = return (List.reverse acc :*: s)
107 loop m s acc = do
115 loop m s acc = do
108− a :*: s' <- getS s r
116+ a :*: s' <- getR s r
109 loop (m-1) s' (a:acc)
117 loop (m-1) s' (a:acc)
110 in loop n s0 []
118 in loop n s0 []
111 RCheck r c m -> do
119 RCheck r c m -> do
112− a :*: s <- getS s0 r
120+ a :*: s <- getR s0 r
113 if c a
121 if c a
114 then return (a :*: s)
122 then return (a :*: s)
115 else fail m
123 else fail m
@@ -198,9 +206,7 @@ readWord16be s@(S bs o) n
198readWithoutOffset s@(S bs o) shifterL shifterR n
206readWithoutOffset s@(S bs o) shifterL shifterR n
199 | o /= 0 = error "readWithoutOffset: there is an offset"
207 | o /= 0 = error "readWithoutOffset: there is an offset"
200
208
201− -- | n == 8 = readWord8 s n
209+ | bit_offset n == 0 && byte_offset n <= 4 =
202− -- | n == 16 = readWord16be s n
203− | n == 24 || n == 32 =
204 let segs = byte_offset n
210 let segs = byte_offset n
205 bn 0 = fromIntegral (unsafeHead bs)
211 bn 0 = fromIntegral (unsafeHead bs)
206 bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
212 bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
@@ -247,13 +253,27 @@ readWord32be s@(S bs o) n
247 in fromIntegral w :*: s'
253 in fromIntegral w :*: s'
248
254
249 | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
255 | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
250− -- error "readWord32be: can't read without offset..."
251
256
252 | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
257 | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
253
258
254 | otherwise = error "readWord32be: tried to read more than 32 bits"
259 | otherwise = error "readWord32be: tried to read more than 32 bits"
255
260
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"
257
277
258------------------------------------------------------------------------
278------------------------------------------------------------------------
259-- unrolled codensity/state monad
279-- unrolled codensity/state monad
@@ -261,29 +281,57 @@ newtype BitGet a = C { runCont :: forall r.
261 S ->
281 S ->
262 Failure r ->
282 Failure r ->
263 Success a r ->
283 Success a r ->
264− Either String r }
284+ Get (Either String r) }
265
285
266−type Failure r = String -> Either String r
286+type Failure r = String -> Get (Either String r)
267−type Success a r = S -> a -> Either String r
287+type Success a r = S -> a -> Get (Either String r)
268
288
269instance Monad BitGet where
289instance Monad BitGet where
270 return x = C $ \s kf ks -> ks s x
290 return x = C $ \s kf ks -> ks s x
271 fail str = C $ \s kf ks -> kf str
291 fail str = C $ \s kf ks -> kf str
272 (C c) >>= f = C $ \s kf ks -> c s kf (\s' a -> runCont (f a) s' kf ks)
292 (C c) >>= f = C $ \s kf ks -> c s kf (\s' a -> runCont (f a) s' kf ks)
273
293
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+
274−runBitGet :: BitGet a -> Int -> Get (Either String a)
301+runBitGet :: BitGet a -> Get (Either String a)
275−runBitGet bg size = do
302+runBitGet bg = do
276− bs <- getByteString size
303+ bs <- getS -- get the current chunk
304+ putS B.empty
277− return $ runCont bg (S bs 0) (\str -> Left str) (\s a -> Right a)
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
278
326
279getWord8 :: Int -> BitGet Word8
327getWord8 :: Int -> BitGet Word8
280−getWord8 = modifyState . flip readWord8
328+getWord8 n = ensure n >> modifyState (flip readWord8 n)
281
329
282getWord16be :: Int -> BitGet Word16
330getWord16be :: Int -> BitGet Word16
283−getWord16be = modifyState . flip readWord16be
331+getWord16be n = ensure n >> modifyState (flip readWord16be n)
284
332
285getWord32be :: Int -> BitGet Word32
333getWord32be :: Int -> BitGet Word32
286−getWord32be = modifyState . flip readWord32be
334+getWord32be n = ensure n >> modifyState (flip readWord32be n)
287
335
288getState :: BitGet S
336getState :: BitGet S
289getState = C $ \s kf ks -> ks s s
337getState = C $ \s kf ks -> ks s s
@@ -294,7 +342,6 @@ putState s = C $ \_ kf ks -> ks s ()
294modifyState :: (S -> (T a S)) -> BitGet a
342modifyState :: (S -> (T a S)) -> BitGet a
295modifyState f = C $ \s kf ks -> case f s of
343modifyState f = C $ \s kf ks -> case f s of
296 w :*: s' -> ks s' w
344 w :*: s' -> ks s' w
297−-}
298
345
299------------------------------------------------------------------------
346------------------------------------------------------------------------
300-- Unchecked shifts, from the package binary
347-- Unchecked shifts, from the package binary
binary-bits.cabal+1−1
@@ -20,7 +20,7 @@ cabal-version: >=1.8
20
20
21
21
22library
22library
23− exposed-modules: Bits
23+ exposed-modules: BitsGet
24
24
25 build-depends: base==4.*, binary, bytestring
25 build-depends: base==4.*, binary, bytestring
26 -- other-modules:
26 -- other-modules: