git.iko.soy/binary-bits
on master help sign in
Start of a bit parsing library
fa0393fLennart Kolmodin
Bits.hsnew file+307
compare with master
unifiedsplit
@@ -0,0 +1,307 @@
1+{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
2+
3+module Bits ( R(..)
4+ , T(..)
5+ , get
6+ , getS
7+ , readBool
8+ , readWord8
9+ , readWord16be
10+ {-
11+ , runBitGet
12+ , BitGet
13+ -}
14+
15+ ) where
16+
17+import Data.Binary.Get
18+
19+import Data.ByteString
20+import Data.ByteString.Internal
21+import Data.ByteString.Unsafe
22+
23+import qualified Data.ByteString.Lazy as L
24+
25+import Data.Bits
26+import Data.Word
27+import Data.List as List ( reverse )
28+
29+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
30+import GHC.Base hiding ( (:*:) )
31+import GHC.Word
32+import GHC.Int
33+#endif
34+
35+data R a where
36+ RBool :: R Bool
37+ RWord8 :: Int -> R Word8
38+ RWord16be :: Int -> R Word16
39+ RWord32be :: Int -> R Word32
40+ RNextTo :: R a -> R b -> R (T a b)
41+ RList :: R a -> Int -> R [a]
42+ RCheck :: R a -> (a -> Bool) -> String -> R a
43+
44+data T a b = !a :*: !b deriving (Show)
45+
46+instance Show (R a) where
47+ show r = case r of
48+ RBool -> "Bool"
49+
50+size_in_bits :: forall a. R a -- ^ The record
51+ -> Int -- ^ Number of bits
52+size_in_bits r = case r of
53+ RBool -> 1
54+ RWord8 n -> min n 8
55+ RWord16be n -> min n 16
56+ RWord32be n -> min n 16
57+ RList r n -> n * size_in_bits r
58+ --RCase r cs -> size_in_bits r + maximum (map size_in_bits cs)
59+ RCheck r _ _ -> size_in_bits r
60+ RNextTo a b -> size_in_bits a + size_in_bits b
61+
62+data S = S !ByteString -- ^ Input
63+ !Int -- ^ Bit offset (0-7)
64+ deriving (Show)
65+
66+size_in_bytes :: forall a. R a
67+ -> Int
68+size_in_bytes r = (size_in_bits r + 7) `div` 8
69+
70+get :: R a -> Get a
71+get r = do
72+ bs <- getByteString (size_in_bytes r)
73+ a :*: s <- getS (S bs 0) r
74+ return a
75+
76+getS :: Monad m => S -> R a -> m (T a S)
77+getS s0 r = do
78+ case r of
79+ RBool -> return (readBool s0)
80+ RWord8 n -> return (readWord8 s0 n)
81+ RWord16be n -> return (readWord16be s0 n)
82+ RNextTo a b -> do
83+ t :*: s <- getS s0 a
84+ u :*: s' <- getS s b
85+ return (t:*:u:*:s')
86+ RList r n ->
87+ let loop 0 s acc = return (List.reverse acc :*: s)
88+ loop m s acc = do
89+ a :*: s' <- getS s r
90+ loop (m-1) s' (a:acc)
91+ in loop n s0 []
92+ RCheck r c m -> do
93+ a :*: s <- getS s0 r
94+ if c a
95+ then return (a :*: s)
96+ else fail m
97+
98+-- make_mask 3 = 00000111
99+make_mask :: Bits a => Int -> a
100+make_mask n = (1 `shiftL` fromIntegral n) - 1
101+{-# SPECIALIZE make_mask :: Int -> Word #-}
102+{-# SPECIALIZE make_mask :: Int -> Word8 #-}
103+{-# SPECIALIZE make_mask :: Int -> Word16 #-}
104+{-# SPECIALIZE make_mask :: Int -> Word32 #-}
105+{-# SPECIALIZE make_mask :: Int -> Word64 #-}
106+
107+readBool :: S -> T Bool S
108+readBool s@(S bs n) = testBit (unsafeHead bs) (7-n) :*: incS s 1
109+
110+incS :: S -> Int -> S
111+incS (S bs n) 1 =
112+ let
113+ n' = n + 1
114+ s' | n' == 8 = S (unsafeTail bs) 0
115+ | otherwise = S bs n'
116+ in s'
117+incS (S bs n) o =
118+ let (d,n') = divMod (n+o) 8
119+ in S (unsafeDrop d bs) n'
120+
121+readWord8 :: S -> Int -> T Word8 S
122+readWord8 s@(S bs o) n
123+ -- no bits at all, return 0
124+ | n == 0 = 0 :*: s
125+
126+ -- all bits are in the same byte
127+ -- we just need to shift and mask them right
128+ | n <= 8 - o = let w = unsafeHead bs
129+ m = make_mask n
130+ w' = (w `shiftr_w8` (8 - o - n)) .&. m
131+ in w' :*: incS s n
132+
133+ -- the bits are in two different bytes
134+ -- make a word16 using both bytes, and then shift and mask
135+ | n <= 8 = let w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.
136+ (fromIntegral (unsafeIndex bs 1))
137+ m = make_mask n
138+ w' = (w `shiftr_w16` (16 - o - n)) .&. m
139+ in fromIntegral w' :*: incS s n
140+
141+bit_offset :: Int -> Int
142+bit_offset n = make_mask 3 .&. n
143+
144+byte_offset :: Int -> Int
145+byte_offset n = n `shiftR` 3
146+
147+readWord16be :: S -> Int -> T Word16 S
148+readWord16be s@(S bs o) n
149+
150+ -- 8 or fewer bits, use readWord8
151+ | n <= 8 = let w :*: s' = readWord8 s n
152+ in fromIntegral w :*: s'
153+
154+ -- handle 9 or more bits, stored in two bytes
155+
156+ -- no offset, plain and simple 16 bytes
157+ | o == 0 && n == 16 = let msb = fromIntegral (unsafeHead bs)
158+ lsb = fromIntegral (unsafeIndex bs 1)
159+ w = (msb `shiftl_w16` 8) .|. lsb
160+ in w :*: incS s n
161+
162+ -- no offset, but not full 16 bytes
163+ | o == 0 = let msb = fromIntegral (unsafeHead bs)
164+ lsb = fromIntegral (unsafeIndex bs 1)
165+ w = (msb `shiftl_w16` (n-8)) .|. (lsb `shiftr_w16` (16-n))
166+ in w :*: incS s n
167+
168+ -- with offset, and n=9-16
169+ | n <= 16 = let bits_in_msb = 8 - o
170+ (n',top) = (n - bits_in_msb
171+ , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shiftl_w16` (n - bits_in_msb))
172+
173+ segs = byte_offset n
174+
175+ bn 1 = fromIntegral (unsafeIndex bs 1)
176+ bn n = (bn (n-1) `shiftl_w16` 8) .|. fromIntegral (unsafeIndex bs n)
177+
178+ mseg = bn segs
179+
180+ last | bit_offset n' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shiftr_w16` (8 - (bit_offset n'))
181+ | otherwise = 0
182+
183+ w = top .|. mseg .|. last
184+ in w :*: incS s n
185+
186+ | otherwise = error "readWord16be: tried to read more than 16 bits"
187+
188+readWithOffset s@(S bs o) shifterL shifterR n
189+ | n <= 64 = let bits_in_msb = 8 - o
190+ (n',top) = (n - bits_in_msb
191+ , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` (n - bits_in_msb))
192+
193+ segs = byte_offset n
194+
195+ bn 1 = fromIntegral (unsafeIndex bs 1)
196+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
197+
198+ mseg = bn segs
199+
200+ last | bit_offset n' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shifterR` (8 - (bit_offset n'))
201+ | otherwise = 0
202+
203+ w = top .|. mseg .|. last
204+ in w :*: incS s n
205+
206+
207+readWord32be :: S -> Int -> T Word32 S
208+readWord32be s@(S bs o) n
209+ -- 8 or fewer bits, use readWord8
210+ | n <= 8 = let w :*: s' = readWord8 s n
211+ in fromIntegral w :*: s'
212+
213+ -- 16 or fewer bits, use readWord16be
214+ | n <= 16 = let w :*: s' = readWord16be s n
215+ in fromIntegral w :*: s'
216+
217+ -- not implemented
218+ | otherwise = error "readWord32be: Not fully implemented"
219+
220+{-
221+
222+------------------------------------------------------------------------
223+-- unrolled codensity/state monad
224+newtype BitGet a = C { runCont :: forall r.
225+ S ->
226+ Failure r ->
227+ Success a r ->
228+ Either String r }
229+
230+type Failure r = String -> Either String r
231+type Success a r = S -> a -> Either String r
232+
233+instance Monad BitGet where
234+ return x = C $ \s kf ks -> ks s x
235+ fail str = C $ \s kf ks -> kf str
236+ (C c) >>= f = C $ \s kf ks -> c s kf (\s' a -> runCont (f a) s' kf ks)
237+
238+runBitGet :: BitGet a -> Int -> Get (Either String a)
239+runBitGet bg size = do
240+ bs <- getByteString size
241+ return $ runCont bg (S bs 0) (\str -> Left str) (\s a -> Right a)
242+
243+getWord8 :: Int -> BitGet Word8
244+getWord8 = modifyState . flip readWord8
245+
246+getWord16be :: Int -> BitGet Word16
247+getWord16be = modifyState . flip readWord16be
248+
249+getWord32be :: Int -> BitGet Word32
250+getWord32be = modifyState . flip readWord32be
251+
252+getState :: BitGet S
253+getState = C $ \s kf ks -> ks s s
254+
255+putState :: S -> BitGet ()
256+putState s = C $ \_ kf ks -> ks s ()
257+
258+modifyState :: (S -> (T a S)) -> BitGet a
259+modifyState f = C $ \s kf ks -> case f s of
260+ w :*: s' -> ks s' w
261+-}
262+
263+------------------------------------------------------------------------
264+-- Unchecked shifts, from the package binary
265+
266+shiftl_w16 :: Word16 -> Int -> Word16
267+shiftl_w32 :: Word32 -> Int -> Word32
268+shiftl_w64 :: Word64 -> Int -> Word64
269+
270+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
271+shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
272+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
273+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
274+
275+shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
276+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
277+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
278+
279+
280+#if WORD_SIZE_IN_BITS < 64
281+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
282+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
283+
284+#if __GLASGOW_HASKELL__ <= 606
285+-- Exported by GHC.Word in GHC 6.8 and higher
286+foreign import ccall unsafe "stg_uncheckedShiftL64"
287+ uncheckedShiftL64# :: Word64# -> Int# -> Word64#
288+foreign import ccall unsafe "stg_uncheckedShiftRL64"
289+ uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
290+#endif
291+
292+#else
293+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
294+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
295+#endif
296+
297+#else
298+shiftl_w8 = shiftL
299+shiftl_w16 = shiftL
300+shiftl_w32 = shiftL
301+shiftl_w64 = shiftL
302+
303+shiftr_w8 = shiftR
304+shiftr_w16 = shiftR
305+shiftr_w32 = shiftR
306+shiftr_w64 = shiftR
307+#endif
BitsQC.hsnew file+63
@@ -0,0 +1,63 @@
1+module Main where
2+
3+import Data.Binary ( encode )
4+import Data.Binary.Get
5+import Data.Binary.Put
6+
7+import Data.Word
8+import System.Random
9+
10+import Bits
11+
12+import Test.QuickCheck
13+
14+main = quickCheck prop_Word16be_with_offset
15+
16+prop_Word16be_with_offset :: Word16 -> Property
17+prop_Word16be_with_offset w = w < 0x8000 ==>
18+ let b :*: w' :*: w'' = runGet (get (RCheck RBool not "fail" `RNextTo` RWord16be 15 `RNextTo` RWord16be 16)) lbs
19+ in w == w' && w == w''
20+ where
21+ lbs = runPut (putWord16be w >> putWord16be w)
22+
23+instance Arbitrary Word8 where
24+ arbitrary = choose (minBound, maxBound)
25+ shrink 0 = []
26+ shrink n = [ n - 1 ]
27+
28+instance Arbitrary Word16 where
29+ arbitrary = choose (minBound, maxBound)
30+ shrink 0 = []
31+ shrink n = [ n - 1000, n - 100, n - 10, n - 1 ]
32+
33+instance Arbitrary Word32 where
34+ arbitrary = choose (minBound, maxBound)
35+
36+instance Arbitrary Word64 where
37+ arbitrary = choose (minBound, maxBound)
38+
39+
40+integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
41+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
42+ fromIntegral b :: Integer) g of
43+ (x,g) -> (fromIntegral x, g)
44+
45+instance Random Word where
46+ randomR = integralRandomR
47+ random = randomR (minBound,maxBound)
48+
49+instance Random Word8 where
50+ randomR = integralRandomR
51+ random = randomR (minBound,maxBound)
52+
53+instance Random Word16 where
54+ randomR = integralRandomR
55+ random = randomR (minBound,maxBound)
56+
57+instance Random Word32 where
58+ randomR = integralRandomR
59+ random = randomR (minBound,maxBound)
60+
61+instance Random Word64 where
62+ randomR = integralRandomR
63+ random = randomR (minBound,maxBound)