git.iko.soy/binary-bits
on 7ad3838 help sign in
21adca7
swap
0 ahead, 91 behind
.gitignoredeleted−4
since splitsnapshots
unifiedsplit
@@ -1,4 +0,0 @@
1−.cabal-sandbox
2−cabal.sandbox.config
3−dist/
4−.stack-work
.travis.ymldeleted−41
@@ -1,41 +0,0 @@
1−# NB: don't set `language: haskell` here
2−# See https://github.com/hvr/multi-ghc-travis for more information
3−
4−env:
5− - CABALVER=1.18 GHCVER=7.4.2
6− - CABALVER=1.18 GHCVER=7.6.3
7− - CABALVER=1.18 GHCVER=7.8.3
8− - CABALVER=1.22 GHCVER=7.10.1
9−
10−before_install:
11− - sudo add-apt-repository -y ppa:hvr/ghc
12− - sudo apt-get update
13− - sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
14− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
15−
16−install:
17− - cabal update
18− - cabal sandbox init
19− - cabal install --only-dependencies --enable-tests --enable-benchmarks
20−
21−script:
22− - cabal configure --enable-tests --enable-benchmarks -v2
23− - cabal build
24− - cabal test
25−# "cabal check" disabled due to -O2 warning
26−# - cabal check
27− - cabal sdist
28−# check that the generated source-distribution can be built & installed
29− - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
30− cd dist/;
31− cabal sandbox init;
32− if [ -f "$SRC_TGZ" ]; then
33− cabal install --force-reinstalls "$SRC_TGZ";
34− else
35− echo "expected '$SRC_TGZ' not found";
36− exit 1;
37− fi
38−
39−notifications:
40− email:
41− - kolmodin@gmail.com
Bits.hsnew file+30
@@ -0,0 +1,30 @@
1+module Bits where
2+
3+import BitsGet
4+import BitsPut
5+
6+import Data.Word
7+
8+class BinaryBit a where
9+ putBits :: Int -> a -> BitPut ()
10+ getBits :: Int -> BitGet a
11+
12+instance BinaryBit Bool where
13+ putBits _ = putBool
14+ getBits _ = getBool
15+
16+instance BinaryBit Word8 where
17+ putBits = putWord8
18+ getBits = getWord8
19+
20+instance BinaryBit Word16 where
21+ putBits = putWord16be
22+ getBits = getWord16be
23+
24+instance BinaryBit Word32 where
25+ putBits = putWord32be
26+ getBits = getWord32be
27+
28+instance BinaryBit Word64 where
29+ putBits = putWord64be
30+ getBits = getWord64be
BitsGet.hsnew file+424
@@ -0,0 +1,424 @@
1+{-# LANGUAGE GADTs, RankNTypes, MagicHash, CPP #-}
2+
3+module BitsGet
4+ ( T(..)
5+ , runBitGet
6+ , runBitGetSimple
7+ , BitGet
8+ , joinGet
9+
10+ , getBool
11+ , getWord8
12+ , getWord16be
13+ , getWord32be
14+ , getWord64be
15+
16+ , readBool
17+ , readWord8
18+ , readWord16be
19+
20+ ) where
21+
22+import Data.Binary.Get ( runGet, Get, needMore, getByteString, getS, putS )
23+
24+import Data.ByteString as B
25+import Data.ByteString.Internal
26+import Data.ByteString.Unsafe
27+
28+import qualified Data.ByteString.Lazy as L
29+
30+import Data.Bits
31+import Data.Word
32+import Data.List as List ( reverse )
33+
34+import Control.Applicative
35+
36+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
37+import GHC.Base hiding ( (:*:) )
38+import GHC.Word
39+import GHC.Int
40+#endif
41+
42+data T a b = !a :*: !b deriving (Show)
43+
44+data S = S !ByteString -- ^ Input
45+ !Int -- ^ Bit offset (0-7)
46+ deriving (Show)
47+
48+-- make_mask 3 = 00000111
49+make_mask :: Bits a => Int -> a
50+make_mask n = (1 `shiftL` fromIntegral n) - 1
51+{-# SPECIALIZE make_mask :: Int -> Word #-}
52+{-# SPECIALIZE make_mask :: Int -> Word8 #-}
53+{-# SPECIALIZE make_mask :: Int -> Word16 #-}
54+{-# SPECIALIZE make_mask :: Int -> Word32 #-}
55+{-# SPECIALIZE make_mask :: Int -> Word64 #-}
56+
57+readBool :: S -> T Bool S
58+readBool s@(S bs n) = testBit (unsafeHead bs) (7-n) :*: incS s 1
59+
60+incS :: S -> Int -> S
61+incS (S bs n) 1 =
62+ let
63+ n' = n + 1
64+ s' | n' == 8 = S (unsafeTail bs) 0
65+ | otherwise = S bs n'
66+ in s'
67+incS (S bs n) o =
68+ let (d,n') = divMod (n+o) 8
69+ in S (unsafeDrop d bs) n'
70+
71+joinGet :: Get a -> BitGet a
72+joinGet m = C $ \s@(S bs o) kf ks -> do
73+ -- put back the rest of the current chunk
74+ case o of
75+ 0 -> putS bs
76+ _ -> putS (unsafeTail bs)
77+ -- run the get function
78+ a <- m
79+ -- whatever is left, get it and us it as our state
80+ bs' <- getS
81+ let s' = S bs' 0
82+ ks s' a
83+
84+readByteString :: S -> Int -> T ByteString S
85+readByteString s@(S bs o) n
86+ | o == 0 = unsafeTake n bs :*: (S (unsafeDrop n bs) 0)
87+ | otherwise = unsafeTake n (unsafeTail bs) :*: (S (unsafeDrop (n+1) bs) 0)
88+
89+readWord8 :: S -> Int -> T Word8 S
90+readWord8 s@(S bs o) n
91+ -- no bits at all, return 0
92+ | n == 0 = 0 :*: s
93+
94+ -- all bits are in the same byte
95+ -- we just need to shift and mask them right
96+ | n <= 8 - o = let w = unsafeHead bs
97+ m = make_mask n
98+ w' = (w `shiftr_w8` (8 - o - n)) .&. m
99+ in w' :*: incS s n
100+
101+ -- the bits are in two different bytes
102+ -- make a word16 using both bytes, and then shift and mask
103+ | n <= 8 = let w = (fromIntegral (unsafeHead bs) `shiftl_w16` 8) .|.
104+ (fromIntegral (unsafeIndex bs 1))
105+ m = make_mask n
106+ w' = (w `shiftr_w16` (16 - o - n)) .&. m
107+ in fromIntegral w' :*: incS s n
108+
109+bit_offset :: Int -> Int
110+bit_offset n = make_mask 3 .&. n
111+
112+byte_offset :: Int -> Int
113+byte_offset n = n `shiftR` 3
114+
115+readWord16be :: S -> Int -> T Word16 S
116+readWord16be s@(S bs o) n
117+
118+ -- 8 or fewer bits, use readWord8
119+ | n <= 8 = let w :*: s' = readWord8 s n
120+ in fromIntegral w :*: s'
121+
122+ -- handle 9 or more bits, stored in two bytes
123+
124+ -- no offset, plain and simple 16 bytes
125+ | o == 0 && n == 16 = let msb = fromIntegral (unsafeHead bs)
126+ lsb = fromIntegral (unsafeIndex bs 1)
127+ w = (msb `shiftl_w16` 8) .|. lsb
128+ in w :*: incS s n
129+
130+ -- no offset, but not full 16 bytes
131+ | o == 0 = let msb = fromIntegral (unsafeHead bs)
132+ lsb = fromIntegral (unsafeIndex bs 1)
133+ w = (msb `shiftl_w16` (n-8)) .|. (lsb `shiftr_w16` (16-n))
134+ in w :*: incS s n
135+
136+ -- with offset, and n=9-16
137+ | n <= 16 = readWithOffset s shiftl_w16 shiftr_w16 n
138+
139+ | otherwise = error "readWord16be: tried to read more than 16 bits"
140+
141+readWithoutOffset s@(S bs o) shifterL shifterR n
142+ | o /= 0 = error "readWithoutOffset: there is an offset"
143+
144+ | bit_offset n == 0 && byte_offset n <= 4 =
145+ let segs = byte_offset n
146+ bn 0 = fromIntegral (unsafeHead bs)
147+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
148+
149+ in (bn (segs-1) :*: incS s n)
150+
151+ | n <= 64 = let segs = byte_offset n
152+ o' = bit_offset (n - 8 + o)
153+
154+ bn 0 = fromIntegral (unsafeHead bs)
155+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
156+
157+ msegs = bn (segs-1) `shifterL` o'
158+
159+ last = (fromIntegral (unsafeIndex bs segs)) `shifterR` (8 - o')
160+
161+ w = msegs .|. last
162+ in w :*: incS s n
163+
164+readWithOffset s@(S bs o) shifterL shifterR n
165+ | n <= 64 = let bits_in_msb = 8 - o
166+ (n',top) = (n - bits_in_msb
167+ , (fromIntegral (unsafeHead bs) .&. make_mask bits_in_msb) `shifterL` n')
168+
169+ segs = byte_offset n'
170+
171+ bn 0 = 0
172+ bn 1 = fromIntegral (unsafeIndex bs 1)
173+ bn n = (bn (n-1) `shifterL` 8) .|. fromIntegral (unsafeIndex bs n)
174+
175+ o' = bit_offset n'
176+
177+ mseg = bn segs `shifterL` o'
178+
179+ last | o' > 0 = (fromIntegral (unsafeIndex bs (segs + 1))) `shifterR` (8 - o')
180+ | otherwise = 0
181+
182+ w = top .|. mseg .|. last
183+ in w :*: incS s n
184+
185+
186+readWord32be :: S -> Int -> T Word32 S
187+readWord32be s@(S bs o) n
188+ -- 8 or fewer bits, use readWord8
189+ | n <= 8 = let w :*: s' = readWord8 s n
190+ in fromIntegral w :*: s'
191+
192+ -- 16 or fewer bits, use readWord16be
193+ | n <= 16 = let w :*: s' = readWord16be s n
194+ in fromIntegral w :*: s'
195+
196+ | o == 0 = readWithoutOffset s shiftl_w32 shiftr_w32 n
197+
198+ | n <= 32 = readWithOffset s shiftl_w32 shiftr_w32 n
199+
200+ | otherwise = error "readWord32be: tried to read more than 32 bits"
201+
202+
203+readWord64be :: S -> Int -> T Word64 S
204+readWord64be s@(S bs o) n
205+ -- 8 or fewer bits, use readWord8
206+ | n <= 8 = let w :*: s' = readWord8 s n
207+ in fromIntegral w :*: s'
208+
209+ -- 16 or fewer bits, use readWord16be
210+ | n <= 16 = let w :*: s' = readWord16be s n
211+ in fromIntegral w :*: s'
212+
213+ | o == 0 = readWithoutOffset s shiftl_w64 shiftr_w64 n
214+
215+ | n <= 64 = readWithOffset s shiftl_w64 shiftr_w64 n
216+
217+ | otherwise = error "readWord64be: tried to read more than 64 bits"
218+
219+------------------------------------------------------------------------
220+-- unrolled codensity/state monad
221+newtype BitGet a = C { runCont :: forall r.
222+ S ->
223+ Failure r ->
224+ Success a r ->
225+ Get (Either String r) }
226+
227+type Failure r = String -> Get (Either String r)
228+type Success a r = S -> a -> Get (Either String r)
229+
230+instance Monad BitGet where
231+ return x = C $ \s kf ks -> ks s x
232+ fail str = C $ \s kf ks -> kf str
233+ (C c) >>= f = C $ \s kf ks -> c s kf (\s' a -> runCont (f a) s' kf ks)
234+
235+instance Functor BitGet where
236+ fmap f m = m >>= \a -> return (f a)
237+
238+instance Applicative BitGet where
239+ pure x = return x
240+ fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
241+
242+runBitGetSimple :: BitGet a -> Get a
243+runBitGetSimple bg = do
244+ v <- runBitGet bg
245+ case v of
246+ Left err -> fail err
247+ Right v -> return v
248+
249+runBitGet :: BitGet a -> Get (Either String a)
250+runBitGet bg = do
251+ bs <- getS -- get the current chunk
252+ putS B.empty
253+ v <- runCont bg (S bs 0) (\str -> return (Left str)) (\s a -> return (Right (s, a)))
254+ case v of
255+ Left err -> return (Left err)
256+ Right ((S bs' n), x) -> do
257+ let bs'' | n > 0 = B.tail bs'
258+ | otherwise = bs'
259+ putS bs''
260+ return (Right x)
261+
262+ensure :: Int -> BitGet ()
263+ensure n = C $ \s kf ks ->
264+ let loop (S bs o) | n <= (B.length bs * 8 - o) = ks (S bs o) ()
265+ | otherwise = do
266+ needMore
267+ bs' <- getS
268+ putS B.empty
269+ loop (S (bs`append`bs') o)
270+ in loop s
271+
272+getBool :: BitGet Bool
273+getBool = ensure 1 >> modifyState readBool
274+
275+getWord8 :: Int -> BitGet Word8
276+getWord8 n = ensure n >> modifyState (flip readWord8 n)
277+
278+getWord16be :: Int -> BitGet Word16
279+getWord16be n = ensure n >> modifyState (flip readWord16be n)
280+
281+getWord32be :: Int -> BitGet Word32
282+getWord32be n = ensure n >> modifyState (flip readWord32be n)
283+
284+getWord64be :: Int -> BitGet Word64
285+getWord64be n = ensure n >> modifyState (flip readWord64be n)
286+
287+getState :: BitGet S
288+getState = C $ \s kf ks -> ks s s
289+
290+putState :: S -> BitGet ()
291+putState s = C $ \_ kf ks -> ks s ()
292+
293+modifyState :: (S -> (T a S)) -> BitGet a
294+modifyState f = C $ \s kf ks -> case f s of
295+ w :*: s' -> ks s' w
296+
297+------------------------------------------------------------------------
298+-- Unchecked shifts, from the package binary
299+
300+shiftl_w16 :: Word16 -> Int -> Word16
301+shiftl_w32 :: Word32 -> Int -> Word32
302+shiftl_w64 :: Word64 -> Int -> Word64
303+
304+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
305+shiftl_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftL#` i)
306+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
307+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
308+
309+shiftr_w8 (W8# w) (I# i) = W8# (w `uncheckedShiftRL#` i)
310+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)
311+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)
312+
313+
314+#if WORD_SIZE_IN_BITS < 64
315+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
316+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
317+
318+#if __GLASGOW_HASKELL__ <= 606
319+-- Exported by GHC.Word in GHC 6.8 and higher
320+foreign import ccall unsafe "stg_uncheckedShiftL64"
321+ uncheckedShiftL64# :: Word64# -> Int# -> Word64#
322+foreign import ccall unsafe "stg_uncheckedShiftRL64"
323+ uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
324+#endif
325+
326+#else
327+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
328+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
329+#endif
330+
331+#else
332+shiftl_w8 = shiftL
333+shiftl_w16 = shiftL
334+shiftl_w32 = shiftL
335+shiftl_w64 = shiftL
336+
337+shiftr_w8 = shiftR
338+shiftr_w16 = shiftR
339+shiftr_w32 = shiftR
340+shiftr_w64 = shiftR
341+#endif
342+
343+{-
344+data R a where
345+ RBool :: R Bool
346+ RWord8 :: Int -> R Word8
347+ RWord16be :: Int -> R Word16
348+ RWord32be :: Int -> R Word32
349+ RByteString :: Int -> R ByteString
350+ RThis :: a -> R a
351+ RNextTo :: R a -> R b -> R (T a b)
352+ RMap :: R b -> (b -> R a) -> R a
353+ RMapPure :: R a -> (a -> b) -> R b
354+ RList :: Int -> R a -> R [a]
355+ RCheck :: R a -> (a -> Bool) -> String -> R a
356+
357+instance Functor R where
358+ fmap f m = RMapPure m f
359+
360+instance Show (R a) where
361+ show r = case r of
362+ RBool -> "Bool"
363+
364+size_in_bits :: forall a. R a -- ^ The record
365+ -> Int -- ^ Number of bits
366+size_in_bits r = case r of
367+ RBool -> 1
368+ RWord8 n -> min n 8
369+ RWord16be n -> min n 16
370+ RWord32be n -> min n 16
371+ RByteString n -> 8 * n
372+ RThis _ -> 0
373+ RList n r -> n * size_in_bits r
374+ RMap r _ -> size_in_bits r
375+ RMapPure r _ -> size_in_bits r
376+ RCheck r _ _ -> size_in_bits r
377+ RNextTo a b -> size_in_bits a + size_in_bits b
378+
379+size_in_bytes :: forall a. R a
380+ -> Int
381+size_in_bytes r = byte_offset (size_in_bits r + 7)
382+
383+get :: R a -> Get a
384+get r = do
385+ bs <- getByteString (size_in_bytes r)
386+ a :*: s <- getR (S bs 0) r
387+ return a
388+
389+getR :: S -> R a -> Get (T a S)
390+getR s0 r = do
391+ case r of
392+ RBool -> return (readBool s0)
393+ RWord8 n -> return (readWord8 s0 n)
394+ RWord16be n -> return (readWord16be s0 n)
395+ RWord32be n -> return (readWord32be s0 n)
396+ RByteString n -> return (readByteString s0 n)
397+ RThis x -> return (x :*: s0)
398+ RNextTo a b -> do
399+ t :*: s <- getR s0 a
400+ u :*: s' <- getR s b
401+ return (t:*:u:*:s')
402+ RMap r p -> do
403+ a :*: s@(S bs o) <- getR s0 r
404+ let codepath = p a
405+ required_bytes = byte_offset (size_in_bits r - o)
406+ bs' <- getByteString required_bytes
407+ getR (S (bs `append` bs') o) codepath
408+ RMapPure r f -> do
409+ a :*: s <- getR s0 r
410+ return (f a :*: s)
411+ RList n r ->
412+ let loop 0 s acc = return (List.reverse acc :*: s)
413+ loop m s acc = do
414+ a :*: s' <- getR s r
415+ loop (m-1) s' (a:acc)
416+ in loop n s0 []
417+ RCheck r c m -> do
418+ a :*: s <- getR s0 r
419+ if c a
420+ then return (a :*: s)
421+ else fail m
422+-}
423+
424+
BitsPut.hsnew file+115
@@ -0,0 +1,115 @@
1+module BitsPut
2+ ( BitPut
3+ , runBitPut
4+ , joinPut
5+
6+ , putBool
7+ , putWord8
8+ , putWord16be
9+ , putWord32be
10+ , putWord64be
11+ )
12+ where
13+
14+import qualified Data.Binary.Builder as B
15+import Data.Binary.Builder ( Builder )
16+import qualified Data.Binary.Put as Put
17+import Data.Binary.Put ( Put )
18+
19+import Data.ByteString
20+
21+import Data.Bits
22+import Data.Monoid
23+import Data.Word
24+
25+data BitPut a = BitPut { run :: (S -> PairS a) }
26+
27+data PairS a = PairS a {-# UNPACK #-} !S
28+
29+data S = S !Builder !Word8 !Int
30+
31+instance Show S where
32+ show (S _ w o) = "S( " ++ show w ++ " : " ++ show o ++ ")"
33+
34+putBool :: Bool -> BitPut ()
35+putBool b = putWord8 1 (if b then 1 else 0)
36+
37+putWord8 :: Int -> Word8 -> BitPut ()
38+putWord8 n w = BitPut $ \s -> PairS () $
39+ case s of
40+ -- a whole word8, no offset
41+ (S b t o) | n == 8 && o == 0 -> flush $ S b w n
42+ -- less than a word8, will fit in the current word8
43+ | n <= 8 - o -> flush $ S b (t .|. (w `shiftL` (8 - n - o))) (o+n)
44+ -- will finish this word8, and spill into the next one
45+ | otherwise -> flush $
46+ let o' = o + n - 8
47+ w' = t .|. (w `shiftR` o')
48+ t' = w `shiftL` (8 - o')
49+ in S (b `mappend` B.singleton w') t' o'
50+
51+putWord16be :: Int -> Word16 -> BitPut ()
52+putWord16be n w
53+ | n <= 8 = putWord8 n (fromIntegral w)
54+ | otherwise =
55+ BitPut $ \s -> PairS () $
56+ case s of
57+ -- as n>=9, it's too big to fit into one single byte
58+ -- it'll either use 2 or 3 bytes
59+ -- it'll fit in 2 bytes
60+ (S b t o) | o + n <= 16 -> flush $
61+ let o' = o + n - 8
62+ w' = t .|. fromIntegral (w `shiftR` o')
63+ t' = fromIntegral (w `shiftL` (8-o'))
64+ in (S (b `mappend` B.singleton w') t' o')
65+ -- 3 bytes required
66+ | otherwise -> flush $
67+ let o' = o + n - 16
68+ w' = t .|. fromIntegral (w `shiftR` (o' + 8))
69+ w'' = fromIntegral ((w `shiftR` o') .&. 0xff)
70+ t' = fromIntegral (w `shiftL` (8-o'))
71+ in (S (b `mappend` B.singleton w' `mappend` B.singleton w'') t' o')
72+
73+putWord32be :: Int -> Word32 -> BitPut ()
74+putWord32be n w
75+ | n <= 16 = putWord16be n (fromIntegral w)
76+ | otherwise = do
77+ putWord32be (n-16) (w`shiftR`16)
78+ putWord32be 16 (w .&. 0x0000ffff)
79+
80+putWord64be :: Int -> Word64 -> BitPut ()
81+putWord64be n w
82+ | n <= 32 = putWord32be n (fromIntegral w)
83+ | otherwise = do
84+ putWord64be (n-32) (w`shiftR`32)
85+ putWord64be 32 (w .&. 0xffffffff)
86+
87+joinPut :: Put -> BitPut ()
88+joinPut m = BitPut $ \s0 -> PairS () $
89+ let (S b0 _ _) = flushIncomplete s0
90+ b = Put.execPut m
91+ in (S (b0`mappend`b) 0 0)
92+
93+flush :: S -> S
94+flush s@(S b w o)
95+ | o > 8 = error "flush: offset > 8"
96+ | o == 8 = S (b `mappend` B.singleton w) 0 0
97+ | otherwise = s
98+
99+flushIncomplete :: S -> S
100+flushIncomplete s@(S b w o)
101+ | o == 0 = s
102+ | otherwise = (S (b `mappend` B.singleton w) 0 0)
103+
104+runBitPut :: BitPut () -> Put.Put
105+runBitPut m = Put.putBuilder b'
106+ where
107+ PairS _ s@(S b t o) = run m (S mempty 0 0)
108+ (S b' _ _) = flushIncomplete s
109+
110+instance Monad BitPut where
111+ m >>= k = BitPut $ \s ->
112+ let PairS a s' = run m s
113+ PairS b s'' = run (k a) s'
114+ in PairS b s''
115+ return x = BitPut $ \s -> PairS x s
BitsQC.hs+138−390
@@ -1,33 +1,43 @@
1−{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}
1+module Main where
2
2
3−module Main ( main ) where
4−
5−import Data.Binary ( Binary(..) )
3+import Data.Binary ( encode, Binary(..) )
6−import Data.Binary.Get ( runGet, runGetIncremental, pushChunks, Decoder(..) )
4+import Data.Binary.Get ( runGet )
7import Data.Binary.Put ( runPut )
5import Data.Binary.Put ( runPut )
8
6
9−import Data.Binary.Bits
7+import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )
10−import Data.Binary.Bits.Get
8+import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, putWord64be )
11−import Data.Binary.Bits.Put
12−import Data.Binary.Bits.BitOrder
13
9
14−import qualified Data.ByteString as B
10+import Bits
15−import qualified Data.ByteString.Lazy as L
16
11
17−import Control.Applicative
18import Data.Bits
12import Data.Bits
13+import Data.Monoid
19import Data.Word
14import Data.Word
20import Foreign.Storable
15import Foreign.Storable
21−import Data.Traversable (traverse)
16+import System.Random
22−import Data.Foldable (traverse_)
17+import System
18+
19+import BitsGet
20+import BitsPut
23
21
22+import Test.Framework.Options ( TestOptions'(..) )
24import Test.Framework.Providers.QuickCheck2 ( testProperty )
23import Test.Framework.Providers.QuickCheck2 ( testProperty )
25−import Test.Framework.Runners.Console ( defaultMain )
24+import Test.Framework.Runners.Console ( defaultMainWithOpts )
25+import Test.Framework.Runners.Options ( RunnerOptions'(..) )
26import Test.Framework ( Test, testGroup )
26import Test.Framework ( Test, testGroup )
27import Test.QuickCheck
27import Test.QuickCheck
28
28
29−main :: IO ()
29+main = do
30−main = defaultMain tests
30+ args <- getArgs
31+ defaultMainWithOpts tests (setMaxTestCases (if null args then 1024 else read (head args)))
32+ where
33+ -- increase the number of test cases
34+ setMaxTestCases n =
35+ mempty
36+ { ropt_test_options = Just $
37+ mempty
38+ { topt_maximum_generated_tests = Just n
39+ }
40+ }
31
41
32tests :: [Test]
42tests :: [Test]
33tests =
43tests =
@@ -37,196 +47,101 @@ tests =
37 , testGroup "Custom test cases"
47 , testGroup "Custom test cases"
38 [ testProperty "prop_composite_case" prop_composite_case ]
48 [ testProperty "prop_composite_case" prop_composite_case ]
39
49
40− , testGroup "getByteString"
41− [ testProperty "prop_getByteString_negative" prop_getByteString_negative
42− , testProperty "prop_putByteString_getByteString" (prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property)
43− , testProperty "prop_putByteString_getByteString_many" (prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property)
44− ]
45−
46− , testGroup "getLazyByteString"
47− [ testProperty "getLazyByteString == getByteString"
48− prop_getLazyByteString_equal_to_ByteString
49− , testProperty "getLazyByteString == getByteString (with shift)"
50− prop_getLazyByteString_equal_to_ByteString2
51− ]
52−
53− , testGroup "isEmpty"
54− [ testProperty "prop_isEmptyOfEmptyEmpty" prop_isEmptyOfEmptyEmpty
55− , testProperty "prop_isEmptyOfNonEmptyEmpty" prop_isEmptyOfNonEmptyEmpty
56− , testProperty "prop_isEmptyOfConsumedEmpty" prop_isEmptyOfConsumedEmpty
57− , testProperty "prop_isEmptyOfNotConsumedNotEmpty" prop_isEmptyOfNotConsumedNotEmpty
58− ]
59−
60− , testGroup "Fail"
61− [ testProperty "monadic fail" prop_fail ]
62−
63 , testGroup "prop_bitput_with_get_from_binary"
50 , testGroup "prop_bitput_with_get_from_binary"
64− [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
51+ [ testProperty "Word8" (prop_bitput_with_get_from_binary :: [Word8] -> Property)
65− , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
52+ , testProperty "Word16" (prop_bitput_with_get_from_binary :: [Word16] -> Property)
66− , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
53+ , testProperty "Word32" (prop_bitput_with_get_from_binary :: [Word32] -> Property)
67− , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
54+ , testProperty "Word64" (prop_bitput_with_get_from_binary :: [Word64] -> Property)
68 ]
55 ]
69
56
70 , testGroup "prop_bitget_with_put_from_binary"
57 , testGroup "prop_bitget_with_put_from_binary"
71− [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
58+ [ testProperty "Word8" (prop_bitget_with_put_from_binary :: [Word8] -> Property)
72− , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
59+ , testProperty "Word16" (prop_bitget_with_put_from_binary :: [Word16] -> Property)
73− , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
60+ , testProperty "Word32" (prop_bitget_with_put_from_binary :: [Word32] -> Property)
74− , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
61+ , testProperty "Word64" (prop_bitget_with_put_from_binary :: [Word64] -> Property)
75 ]
62 ]
76
63
77 , testGroup "prop_compare_put_with_naive"
64 , testGroup "prop_compare_put_with_naive"
78− [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
65+ [ testProperty "Word8" (prop_compare_put_with_naive :: [Word8] -> Property)
79− , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
66+ , testProperty "Word16" (prop_compare_put_with_naive :: [Word16] -> Property)
80− , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
67+ , testProperty "Word32" (prop_compare_put_with_naive :: [Word32] -> Property)
81− , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
68+ , testProperty "Word64" (prop_compare_put_with_naive :: [Word64] -> Property)
82 ]
69 ]
83
70
84 , testGroup "prop_compare_get_with_naive"
71 , testGroup "prop_compare_get_with_naive"
85− [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
72+ [ testProperty "Word8" (prop_compare_get_with_naive:: [Word8] -> Property)
86− , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
73+ , testProperty "Word16" (prop_compare_get_with_naive:: [Word16] -> Property)
87− , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
74+ , testProperty "Word32" (prop_compare_get_with_naive:: [Word32] -> Property)
88− , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
75+ , testProperty "Word64" (prop_compare_get_with_naive:: [Word64] -> Property)
89 ]
76 ]
90
77
91 , testGroup "prop_put_with_bitreq"
78 , testGroup "prop_put_with_bitreq"
92− [ testProperty "Word8" (prop_putget_with_bitreq :: BitOrder -> W Word8 -> Property)
79+ [ testProperty "Word8" (prop_putget_with_bitreq :: Word8 -> Property)
93− , testProperty "Word16" (prop_putget_with_bitreq :: BitOrder -> W Word16 -> Property)
80+ , testProperty "Word16" (prop_putget_with_bitreq :: Word16 -> Property)
94− , testProperty "Word32" (prop_putget_with_bitreq :: BitOrder -> W Word32 -> Property)
81+ , testProperty "Word32" (prop_putget_with_bitreq :: Word32 -> Property)
95− , testProperty "Word64" (prop_putget_with_bitreq :: BitOrder -> W Word64 -> Property)
82+ , testProperty "Word64" (prop_putget_with_bitreq :: Word64 -> Property)
96 ]
83 ]
97
84
98 , testGroup "prop_putget_list_simple"
85 , testGroup "prop_putget_list_simple"
99− [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
86+ [ testProperty "Bool" (prop_putget_list_simple :: [Bool] -> Property)
100− , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
87+ , testProperty "Word8" (prop_putget_list_simple :: [Word8] -> Property)
101− , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
88+ , testProperty "Word16" (prop_putget_list_simple :: [Word16] -> Property)
102− , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
89+ , testProperty "Word32" (prop_putget_list_simple :: [Word32] -> Property)
103− , testProperty "Word64" (prop_putget_list_simple :: W [Word64] -> Property)
90+ , testProperty "Word64" (prop_putget_list_simple :: [Word64] -> Property)
104− ]
105−
106− , testGroup "prop_putget_applicative_with_bitreq"
107− [ testProperty "Word8" (prop_putget_applicative_with_bitreq :: W [(Word8,Word8,Word8)] -> Property)
108− , testProperty "Word16" (prop_putget_applicative_with_bitreq :: W [(Word16,Word16,Word16)] -> Property)
109− , testProperty "Word32" (prop_putget_applicative_with_bitreq :: W [(Word32,Word32,Word32)] -> Property)
110− , testProperty "Word64" (prop_putget_applicative_with_bitreq :: W [(Word64,Word64,Word64)] -> Property)
111 ]
91 ]
112
92
113 , testGroup "prop_putget_list_with_bitreq"
93 , testGroup "prop_putget_list_with_bitreq"
114− [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
94+ [ testProperty "Word8" (prop_putget_list_with_bitreq :: [Word8] -> Property)
115− , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
95+ , testProperty "Word16" (prop_putget_list_with_bitreq :: [Word16] -> Property)
116− , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
96+ , testProperty "Word32" (prop_putget_list_with_bitreq :: [Word32] -> Property)
117− , testProperty "Word64" (prop_putget_list_with_bitreq :: W [Word64] -> Property)
97+ , testProperty "Word64" (prop_putget_list_with_bitreq :: [Word64] -> Property)
118− ]
119− , testGroup "prop_bitget_bytestring_interspersed"
120− [ testProperty "Word8" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word8 -> [B.ByteString] -> Property)
121− , testProperty "Word16" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word16 -> [B.ByteString] -> Property)
122− , testProperty "Word32" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word32 -> [B.ByteString] -> Property)
123− , testProperty "Word64" (prop_bitget_bytestring_interspersed :: BitOrder -> W Word64 -> [B.ByteString] -> Property)
124− ]
125− , testGroup "Simulate programs"
126− [ testProperty "primitive" prop_primitive
127− , testProperty "many primitives in sequence" prop_program
128 ]
98 ]
129 ]
99 ]
130
100
131−prop_isEmptyOfEmptyEmpty :: Bool
101+{-
132−prop_isEmptyOfEmptyEmpty = runGet (runBitGet isEmpty) L.empty
102+ -- these tests use the R structure
133−
103+ --
134−prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> Property
104+ -- quickCheck prop_Word32_from_2_Word16
135−prop_isEmptyOfNonEmptyEmpty bs =
105+ -- quickCheck prop_Word32_from_Word8_and_Word16
136− not (L.null bs) ==> not (runGet (runBitGet isEmpty) bs)
106+-}
137−
107+
138−prop_isEmptyOfConsumedEmpty :: L.ByteString -> Property
139−prop_isEmptyOfConsumedEmpty bs =
140− not (L.null bs) ==>
141− runGet (runBitGet (getByteString n >> isEmpty)) bs
142− where n = fromIntegral $ L.length bs
143−
144−prop_isEmptyOfNotConsumedNotEmpty :: L.ByteString -> Int -> Property
145−prop_isEmptyOfNotConsumedNotEmpty bs n =
146− (fromIntegral n) < L.length bs && not (L.null bs) ==>
147− not (runGet (runBitGet (getByteString n >> isEmpty)) bs)
148−
149−prop_getLazyByteString_equal_to_ByteString :: L.ByteString -> Int -> Property
150−prop_getLazyByteString_equal_to_ByteString bs n =
151− (fromIntegral n) <= L.length bs ==>
152− runGet (runBitGet (getLazyByteString (fromIntegral n))) bs ==
153− (L.fromChunks . (:[]) $ runGet (runBitGet (getByteString n)) bs)
154−
155−prop_getLazyByteString_equal_to_ByteString2 :: L.ByteString -> Int -> Property
156−prop_getLazyByteString_equal_to_ByteString2 bs n =
157− (L.length bs > 1) && (fromIntegral n) < L.length bs ==>
158− runGet (runBitGet (getWord8 2 >> getLazyByteString (fromIntegral n))) bs ==
159− (L.fromChunks . (:[]) $ runGet (runBitGet (getWord8 2 >> getByteString n)) bs)
160−
161−prop_getByteString_negative :: Int -> Property
162−prop_getByteString_negative n =
163− n < 1 ==>
164− runGet (runBitGet (getByteString n)) L.empty == B.empty
165−
166−prop_putByteString_getByteString :: BitOrder -> B.ByteString -> Property
167−prop_putByteString_getByteString bo bs = property $ bs' == bs
168− where
169− n = B.length bs
170− w = runPut (runBitPut (withBitOrder bo (putByteString bs)))
171− bs' = runGet (runBitGet (withBitOrder bo (getByteString n))) w
172−
173−prop_putByteString_getByteString_many :: BitOrder -> [B.ByteString] -> Property
174−prop_putByteString_getByteString_many bo bs = property $ bs' == bs
175− where
176− n = fmap B.length bs
177− w = runPut (runBitPut (withBitOrder bo (traverse_ putByteString bs)))
178− bs' = runGet (runBitGet (withBitOrder bo (traverse getByteString n))) w
179−
180−
181−prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => BitOrder -> W a -> Property
108+prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => a -> Property
182−prop_putget_with_bitreq bo (W w) = property $
109+prop_putget_with_bitreq w = property $
183 -- write all words with as many bits as it's required
110 -- write all words with as many bits as it's required
184 let p = putBits (bitreq w) w
111 let p = putBits (bitreq w) w
185 g = getBits (bitreq w)
112 g = getBits (bitreq w)
186− lbs = runPut (runBitPut (withBitOrder bo p))
113+ lbs = runPut (runBitPut p)
187− w' = runGet (runBitGet (withBitOrder bo g)) lbs
114+ w' = runGet (runBitGetSimple g) lbs
188 in w == w'
115 in w == w'
189
116
190-- | Write a list of items. Each item is written with the maximum amount of
117-- | Write a list of items. Each item is written with the maximum amount of
191-- bits, i.e. 8 for Word8, 16 for Word16, etc.
118-- bits, i.e. 8 for Word8, 16 for Word16, etc.
192−prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
119+prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
193−prop_putget_list_simple (W ws) = property $
120+prop_putget_list_simple ws = property $
194 let s = sizeOf (head ws) * 8
121 let s = sizeOf (head ws) * 8
195− p = mapM_ (putBits s) ws
122+ p = mapM_ (\v -> putBits s v) ws
196 g = mapM (const (getBits s)) ws
123 g = mapM (const (getBits s)) ws
197 lbs = runPut (runBitPut p)
124 lbs = runPut (runBitPut p)
198− ws' = runGet (runBitGet g) lbs
125+ ws' = runGet (runBitGetSimple g) lbs
199 in ws == ws'
126 in ws == ws'
200
127
201-- | Write a list of items. Each item is written with exactly as many bits
128-- | Write a list of items. Each item is written with exactly as many bits
202-- as required. Then read it back.
129-- as required. Then read it back.
203−prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
130+prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
204−prop_putget_list_with_bitreq (W ws) = property $
131+prop_putget_list_with_bitreq ws = property $
205 -- write all words with as many bits as it's required
132 -- write all words with as many bits as it's required
206 let p = mapM_ (\v -> putBits (bitreq v) v) ws
133 let p = mapM_ (\v -> putBits (bitreq v) v) ws
207 g = mapM getBits bitlist
134 g = mapM getBits bitlist
208 lbs = runPut (runBitPut p)
135 lbs = runPut (runBitPut p)
209− ws' = runGet (runBitGet g) lbs
136+ ws' = runGet (runBitGetSimple g) lbs
210 in ws == ws'
137 in ws == ws'
211 where
138 where
212 bitlist = map bitreq ws
139 bitlist = map bitreq ws
213
140
214−prop_putget_applicative_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [(a,a,a)] -> Property
215−prop_putget_applicative_with_bitreq (W ts) = property $
216− let p = mapM_ (\(a,b,c) -> do putBits (bitreq a) a
217− putBits (bitreq b) b
218− putBits (bitreq c) c) ts
219− g = mapM (\(a,b,c) -> (,,) <$> getBits a <*> getBits b <*> getBits c) bitlist
220− lbs = runPut (runBitPut p)
221− ts' = runGet (runBitGet g) lbs
222− in ts == ts'
223− where
224− bitlist = map (\(a,b,c) -> (bitreq a, bitreq b, bitreq c)) ts
225−
226-- | Write bits using this library, and read them back using the binary
141-- | Write bits using this library, and read them back using the binary
227-- library.
142-- library.
228−prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
143+prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
229−prop_bitput_with_get_from_binary (W ws) = property $
144+prop_bitput_with_get_from_binary ws = property $
230 let s = sizeOf (head ws) * 8
145 let s = sizeOf (head ws) * 8
231 p = mapM_ (putBits s) ws
146 p = mapM_ (putBits s) ws
232 g = mapM (const get) ws
147 g = mapM (const get) ws
@@ -236,88 +151,61 @@ prop_bitput_with_get_from_binary (W ws) = property $
236
151
237-- | Write bits using the binary library, and read them back using this
152-- | Write bits using the binary library, and read them back using this
238-- library.
153-- library.
239−prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
154+prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
240−prop_bitget_with_put_from_binary (W ws) = property $
155+prop_bitget_with_put_from_binary ws = property $
241 let s = sizeOf (head ws) * 8
156 let s = sizeOf (head ws) * 8
242 p = mapM_ put ws
157 p = mapM_ put ws
243 g = mapM (const (getBits s)) ws
158 g = mapM (const (getBits s)) ws
244 lbs = runPut p
159 lbs = runPut p
245− ws' = runGet (runBitGet g) lbs
160+ ws' = runGet (runBitGetSimple g) lbs
246 in ws == ws'
161 in ws == ws'
247
162
248−-- | Write each 'ByteString' with a variable sized value as a separator.
249−prop_bitget_bytestring_interspersed :: (BinaryBit a, Binary a, Num a, Ord a, Bits a) => BitOrder -> W a -> [B.ByteString] -> Property
250−prop_bitget_bytestring_interspersed bo (W ws) bss = property $
251− let p = mapM_ (\bs -> putBits (bitreq ws) ws >> putByteString bs) bss
252− g = mapM (\bs -> (,) <$> getBits (bitreq ws) <*> getByteString (B.length bs)) bss
253− lbs = runPut (runBitPut (withBitOrder bo p))
254− r = runGet (runBitGet (withBitOrder bo g)) lbs
255− in map (ws,) bss == r
256−
257−-- | Test failing.
258−prop_fail :: L.ByteString -> String -> Property
259−prop_fail lbs errMsg0 = forAll (choose (0, 8 * L.length lbs)) $ \len ->
260− let (bytes,bits) = len `divMod` 8
261− expectedBytesConsumed
262− | bits == 0 = bytes
263− | otherwise = bytes + 1
264− p = do _ <- getByteString (fromIntegral bytes)
265− _ <- getBits (fromIntegral bits) :: BitGet Word8
266− fail errMsg0
267− r = runGetIncremental (runBitGet p) `pushChunks` lbs
268− in case r of
269− Fail remainingBS pos errMsg ->
270− and [ L.fromChunks [remainingBS] == L.drop expectedBytesConsumed lbs
271− , pos == expectedBytesConsumed
272− , errMsg == errMsg0
273− ]
274− _ -> False
275−
276−-- | number of bits required to write @v@
163+-- number of bits required to write 'v'
277−bitreq :: (Num b, Num a, Bits a, Ord a) => a -> b
164+bitreq :: (Num b, Bits a, Ord a) => a -> b
278bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
165bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
279
166
280−bittable :: (Bits a, Num a) => [(Integer, a)]
167+bittable :: Bits a => [(Integer, a)]
281bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
168bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
282
169
283−prop_bitreq :: W Word64 -> Property
170+prop_bitreq :: Word64 -> Property
284−prop_bitreq (W w) = property $
171+prop_bitreq w = property $
285 ( w == 0 && bitreq w == 1 )
172 ( w == 0 && bitreq w == 1 )
286− || bitreq w == bitreq (w `shiftR` 1) + 1
173+ || bitreq w == (bitreq (w `shiftR` 1)) + 1
287
174
288−prop_composite_case :: Bool -> W Word16 -> Property
175+prop_composite_case :: Bool -> Word16 -> Property
289−prop_composite_case b (W w) = w < 0x8000 ==>
176+prop_composite_case b w = w < 0x8000 ==>
290 let p = do putBool b
177 let p = do putBool b
291− putWord16 15 w
178+ putWord16be 15 w
292 g = do v <- getBool
179 g = do v <- getBool
293 case v of
180 case v of
294− True -> getWord16 15
181+ True -> getWord16be 15
295 False -> do
182 False -> do
296 msb <- getWord8 7
183 msb <- getWord8 7
297 lsb <- getWord8 8
184 lsb <- getWord8 8
298 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
185 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
299 lbs = runPut (runBitPut p)
186 lbs = runPut (runBitPut p)
300− w' = runGet (runBitGet g) lbs
187+ w' = runGet (runBitGetSimple g) lbs
301 in w == w'
188 in w == w'
302
189
190+
303−prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
191+prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => [a] -> Property
304−prop_compare_put_with_naive (W ws) = property $
192+prop_compare_put_with_naive ws = property $
305 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
193 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
306 p = mapM_ (\v -> putBits (bitreq v) v) ws
194 p = mapM_ (\v -> putBits (bitreq v) v) ws
307 lbs_n = runPut (runBitPut pn)
195 lbs_n = runPut (runBitPut pn)
308 lbs = runPut (runBitPut p)
196 lbs = runPut (runBitPut p)
309 in lbs_n == lbs
197 in lbs_n == lbs
310
198
311−prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
199+prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => [a] -> Property
312−prop_compare_get_with_naive (W ws) = property $
200+prop_compare_get_with_naive ws = property $
313 let gn = mapM (\v -> naive_get (bitreq v)) ws
201 let gn = mapM (\v -> naive_get (bitreq v)) ws
314 g = mapM (\v -> getBits (bitreq v)) ws
202 g = mapM (\v -> getBits (bitreq v)) ws
315 p = mapM_ (\v -> naive_put (bitreq v) v) ws
203 p = mapM_ (\v -> naive_put (bitreq v) v) ws
316 lbs = runPut (runBitPut p)
204 lbs = runPut (runBitPut p)
317− rn = runGet (runBitGet gn) lbs
205+ rn = runGet (runBitGetSimple gn) lbs
318− r = runGet (runBitGet g ) lbs
206+ r = runGet (runBitGetSimple g ) lbs
319 -- we must help our compiler to resolve the types of 'gn' and 'g'
207 -- we must help our compiler to resolve the types of 'gn' and 'g'
320− _types = rn == ws && r == ws
208+ types = rn == ws && r == ws
321 in rn == r
209 in rn == r
322
210
323-- | Write one bit at a time until the full word has been written
211-- | Write one bit at a time until the full word has been written
@@ -335,6 +223,27 @@ naive_get n0 =
335 True -> loop (n-1) ((acc `shiftL` 1) + 1)
223 True -> loop (n-1) ((acc `shiftL` 1) + 1)
336 in loop n0 0
224 in loop n0 0
337
225
226+{-
227+prop_Word32_from_Word8_and_Word16 :: Word8 -> Word16 -> Property
228+prop_Word32_from_Word8_and_Word16 w8 w16 = property $
229+ let p = RWord32be 24
230+ w' = runGet (get p) lbs
231+ in w0 == w'
232+ where
233+ lbs = runPut (putWord8 w8 >> putWord16be w16)
234+ w0 = ((fromIntegral w8) `shiftL` 16) .|. fromIntegral w16
235+
236+prop_Word32_from_2_Word16 :: Word16 -> Word16 -> Property
237+prop_Word32_from_2_Word16 w1 w2 = property $
238+ let p = RWord32be 32
239+ w' = runGet (get p) lbs
240+ in w0 == w'
241+ where
242+ lbs = encode w0
243+ w0 = ((fromIntegral w1) `shiftL` 16) .|. fromIntegral w2
244+-}
245+
246+
338shrinker :: (Num a, Ord a, Bits a) => a -> [a]
247shrinker :: (Num a, Ord a, Bits a) => a -> [a]
339shrinker 0 = []
248shrinker 0 = []
340shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
249shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
@@ -346,187 +255,27 @@ shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
346 where
255 where
347 n = bitreq w
256 n = bitreq w
348
257
349−data W a = W { unW :: a } deriving (Show, Eq, Ord)
350−
351−arbitraryW :: (Arbitrary (W a)) => Gen a
352−arbitraryW = unW <$> arbitrary
353−
354−shrinkW :: (Arbitrary (W a)) => a -> [a]
355−shrinkW x = unW <$> shrink (W x)
356−
357−instance Arbitrary (W Bool) where
258+instance Arbitrary Word8 where
358− arbitrary = W <$> arbitrary
359− shrink = map W <$> shrink . unW
360−
361−instance Arbitrary (W Word8) where
362− arbitrary = W <$> choose (minBound, maxBound)
259+ arbitrary = choose (minBound, maxBound)
363− shrink = map W . shrinker . unW
260+ shrink = shrinker
364−
365−instance Arbitrary (W Word16) where
366− arbitrary = W <$> choose (minBound, maxBound)
367− shrink = map W . shrinker . unW
368−
369−instance Arbitrary (W Word32) where
370− arbitrary = W <$> choose (minBound, maxBound)
371− shrink = map W . shrinker . unW
372−
373−instance Arbitrary (W Word64) where
374− arbitrary = W <$> choose (minBound, maxBound)
375− shrink = map W . shrinker . unW
376−
377−instance Arbitrary B.ByteString where
378− arbitrary = B.pack <$> arbitrary
379− shrink bs = B.pack <$> shrink (B.unpack bs)
380−
381−instance Arbitrary L.ByteString where
382− arbitrary = L.fromChunks <$> arbitrary
383− shrink bs = L.fromChunks <$> shrink (L.toChunks bs)
384−
385−instance (Arbitrary (W a)) => Arbitrary (W [a]) where
386− arbitrary = W . map unW <$> arbitrary
387− shrink = map (W . map unW) <$> mapM shrink . map W . unW
388−
389−instance (Arbitrary (W a), Arbitrary (W b)) => Arbitrary (W (a,b)) where
390− arbitrary = (W .) . (,) <$> arbitraryW <*> arbitraryW
391− shrink (W (a,b)) = (W .) . (,) <$> shrinkW a <*> shrinkW b
392−
393−instance (Arbitrary (W a), Arbitrary (W b), Arbitrary (W c)) => Arbitrary (W (a,b,c)) where
394− arbitrary = ((W .) .) . (,,) <$> arbitraryW <*> arbitraryW <*> arbitraryW
395− shrink (W (a,b,c)) = ((W .) .) . (,,) <$> shrinkW a <*> shrinkW b <*> shrinkW c
396−
397−data Primitive
398− = Bool Bool
399− | W8 Int Word8
400− | W16 Int Word16
401− | W32 Int Word32
402− | W64 Int Word64
403− | BS Int B.ByteString
404− | LBS Int L.ByteString
405− | Skip Int
406− | IsEmpty
407− deriving (Eq, Show)
408−
409−type Program = [Primitive]
410−
411−instance Arbitrary Primitive where
412− arbitrary = do
413− let gen c = do
414− let (maxBits, _) = (\w -> (finiteBitSize w, c undefined w)) undefined
415− bits <- choose (0, maxBits)
416− n <- choose (0, fromIntegral (2^bits-1))
417− return (c bits n)
418− oneof
419− [ Bool <$> arbitrary
420− , gen W8
421− , gen W16
422− , gen W32
423− , gen W64
424− , Skip <$> choose (0, 3000)
425− , do n <- choose (0,10)
426− cs <- vector n
427− return (BS n (B.pack cs))
428− , do n <- choose (0,10)
429− cs <- vector n
430− return (LBS n (L.pack cs))
431− , return IsEmpty
432− ]
433− shrink p =
434− let snk c x = map (\x' -> c (bitreq x') x') (shrinker x) in
435− case p of
436− Bool b -> if b then [Bool False] else []
437− W8 _ x -> snk W8 x
438− W16 _ x -> snk W16 x
439− W32 _ x -> snk W32 x
440− W64 _ x -> snk W64 x
441− Skip x -> Skip <$> shrink x
442− BS _ bs -> let ws = B.unpack bs in map (\ws' -> BS (length ws') (B.pack ws')) (shrink ws)
443− LBS _ lbs -> let ws = L.unpack lbs in map (\ws' -> LBS (length ws') (L.pack ws')) (shrink ws)
444− IsEmpty -> []
445−
446−instance Arbitrary BitOrder where
447− arbitrary = elements [BB, LB, LL, BL]
448− shrink LL = [BB,LB,BL]
449− shrink BL = [BB,LB]
450− shrink LB = [BB]
451− shrink BB = []
452−
453−
454−prop_primitive :: Primitive -> Property
455−prop_primitive prim = property $
456− let p = putPrimitive prim
457− g = getPrimitive prim
458− lbs = runPut (runBitPut p)
459− r = runGet (runBitGet g) lbs
460− in r == prim
461
261
462−prop_program :: Program -> Property
262+instance Arbitrary Word16 where
463−prop_program program = property $
263+ arbitrary = choose (minBound, maxBound)
464− let p = mapM_ putPrimitive program
264+ shrink = shrinker
465− g = verifyProgram (8 * fromIntegral (L.length lbs)) program
265+
466− lbs = runPut (runBitPut p)
266+instance Arbitrary Word32 where
467− r = runGet (runBitGet g) lbs
267+ arbitrary = choose (minBound, maxBound)
468− in r
268+ shrink = shrinker
469−
269+
470−putPrimitive :: Primitive -> BitPut ()
270+instance Arbitrary Word64 where
471−putPrimitive p =
271+ arbitrary = choose (minBound, maxBound)
472− case p of
272+ shrink = shrinker
473− Bool b -> putBool b
273+
474− W8 n x -> putWord8 n x
274+integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
475− W16 n x -> putWord16 n x
275+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
476− W32 n x -> putWord32 n x
276+ fromIntegral b :: Integer) g of
477− W64 n x -> putWord64 n x
277+ (x,g) -> (fromIntegral x, g)
478− Skip n -> skipBits n
479− BS _ bs -> putByteString bs
480− LBS _ lbs -> mapM_ putByteString (L.toChunks lbs)
481− IsEmpty -> return ()
482−
483−getPrimitive :: Primitive -> BitGet Primitive
484−getPrimitive p =
485− case p of
486− Bool _ -> Bool <$> getBool
487− W8 n _ -> W8 n <$> getWord8 n
488− W16 n _ -> W16 n <$> getWord16 n
489− W32 n _ -> W32 n <$> getWord32 n
490− W64 n _ -> W64 n <$> getWord64 n
491− Skip n -> skipBits n >> return (Skip n)
492− BS n _ -> BS n <$> getByteString n
493− LBS n _ -> LBS n <$> getLazyByteString n
494− IsEmpty -> isEmpty >> return IsEmpty
495−
496−getPrimitiveSize :: Primitive -> Int
497−getPrimitiveSize p = case p of
498− Bool _ -> 1
499− W8 n _ -> n
500− W16 n _ -> n
501− W32 n _ -> n
502− W64 n _ -> n
503− Skip n -> n
504− BS n _ -> n*8
505− LBS n _ -> n*8
506− IsEmpty -> 0
507−
508−verifyProgram :: Int -> Program -> BitGet Bool
509−verifyProgram totalLength ps0 = go 0 ps0
510− where
511− go _ [] = return True
512− go pos (p:ps) =
513− case p of
514− IsEmpty -> do
515− let expected = pos == totalLength
516− actual <- isEmpty
517− if expected == actual
518− then go pos ps
519− else error $ "isEmpty returned wrong value, expected "
520− ++ show expected ++ " but got " ++ show actual
521− _ -> check p (getPrimitive p) >> go (pos + getPrimitiveSize p) ps
522− check x g = do
523− y <- g
524− if x == y
525− then return ()
526− else error $ "Roundtrip error: Expected "
527− ++ show x ++ " but got " ++ show y
528
278
529−{-
530instance Random Word where
279instance Random Word where
531 randomR = integralRandomR
280 randomR = integralRandomR
532 random = randomR (minBound,maxBound)
281 random = randomR (minBound,maxBound)
@@ -546,4 +295,3 @@ instance Random Word32 where
546instance Random Word64 where
295instance Random Word64 where
547 randomR = integralRandomR
296 randomR = integralRandomR
548 random = randomR (minBound,maxBound)
297 random = randomR (minBound,maxBound)
549−-}
Data/Binary/Bits.hsdeleted−45
@@ -1,45 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.Binary.Bits
4−-- Copyright : (c) Lennart Kolmodin 2010-2011
5−-- License : BSD3-style (see LICENSE)
6−--
7−-- Maintainer : kolmodin@gmail.com
8−-- Stability : experimental
9−-- Portability : portable (should run where the package binary runs)
10−--
11−-- Parse and write bits easily. Parsing can be done either in a monadic style, or more
12−-- efficiently, using the 'Applicative' style. Writing is monadic style only.
13−-- See "Data.Binary.Bits.Get" and "Data.Binary.Bits.Put", respectively.
14−-----------------------------------------------------------------------------
15−
16−module Data.Binary.Bits where
17−
18−import Data.Binary.Bits.Get
19−import Data.Binary.Bits.Put
20−
21−import Data.Word
22−
23−class BinaryBit a where
24− putBits :: Int -> a -> BitPut ()
25− getBits :: Int -> BitGet a
26−
27−instance BinaryBit Bool where
28− putBits _ = putBool
29− getBits _ = getBool
30−
31−instance BinaryBit Word8 where
32− putBits = putWord8
33− getBits = getWord8
34−
35−instance BinaryBit Word16 where
36− putBits = putWord16
37− getBits = getWord16
38−
39−instance BinaryBit Word32 where
40− putBits = putWord32
41− getBits = getWord32
42−
43−instance BinaryBit Word64 where
44− putBits = putWord64
45− getBits = getWord64
Data/Binary/Bits/Alignment.hsdeleted−22
@@ -1,22 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.Binary.Bits.Get
4−-- Copyright : (c) Lennart Kolmodin 2010-2011
5−-- (c) Sylvain Henry 2015
6−-- License : BSD3-style (see LICENSE)
7−--
8−-- Maintainer : kolmodin@gmail.com
9−-- Stability : experimental
10−-- Portability : portable (should run where the package binary runs)
11−
12−module Data.Binary.Bits.Alignment
13− ( Alignable(..)
14− )
15−where
16−
17−class Monad m => Alignable m where
18− -- | Skip the given number of bits
19− skipBits :: Int -> m ()
20−
21− -- | Skip bits if necessary to align to the next byte
22− alignByte :: m ()
Data/Binary/Bits/BitOrder.hsdeleted−47
@@ -1,47 +0,0 @@
1−-----------------------------------------------------------------------------
2−-- |
3−-- Module : Data.Binary.Bits.Get
4−-- Copyright : (c) Lennart Kolmodin 2010-2011
5−-- (c) Sylvain Henry 2015
6−-- License : BSD3-style (see LICENSE)
7−--
8−-- Maintainer : kolmodin@gmail.com
9−-- Stability : experimental
10−-- Portability : portable (should run where the package binary runs)
11−
12−module Data.Binary.Bits.BitOrder
13− ( BitOrder(..)
14− , BitOrderable(..)
15− )
16−where
17−
18−-- | Bit order
19−--
20−-- E.g. two words of 5 bits: ABCDE, VWXYZ
21−-- - BB: ABCDEVWX YZxxxxxx
22−-- - LL: XYZABCDE xxxxxxVW
23−-- - BL: EDCBAZYX WVxxxxxx
24−-- - LB: XWVEDCBA xxxxxxZY
25−data BitOrder
26− = BB -- ^ Big-endian bytes and bits
27− | LB -- ^ Little-endian bytes, big-endian bits
28− | BL -- ^ Big-endian bytes, little-endian bits
29− | LL -- ^ Little-endian bytes and bits
30− deriving (Show)
31−
32−
33−class Monad m => BitOrderable m where
34− -- | Set the current bit-order
35− setBitOrder :: BitOrder -> m ()
36−
37− -- | Retrieve the current bit-order
38− getBitOrder :: m BitOrder
39−
40− -- | Perform the given action with the given bit-order
41− withBitOrder :: BitOrder -> m a -> m a
42− withBitOrder bo act = do
43− bo' <- getBitOrder
44− setBitOrder bo
45− r <- act
46− setBitOrder bo'
47− return r
Data/Binary/Bits/Get.hsdeleted−496
@@ -1,496 +0,0 @@
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−-----------------------------------------------------------------------------
51−
52−module Data.Binary.Bits.Get
53− (
54− -- * BitGet monad
55−
56− -- $bitget
57−
58− BitGet
59− , runBitGet
60−
61− -- ** Get bytes
62− , getBool
63− , getBool#
64− , getWord8
65− , getWord16
66− , getWord32
67− , getWord64
68− , getWord16be
69− , getWord32be
70− , getWord64be
71−
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
92− , Data.Binary.Bits.Get.getByteString
93− , Data.Binary.Bits.Get.getLazyByteString
94− , Data.Binary.Bits.Get.isEmpty
95−
96− ) where
97−
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
103−
104−import Data.ByteString as B
105−import qualified Data.ByteString.Lazy as L
106−import Data.ByteString.Unsafe
107−import Foreign.Marshal.Alloc (mallocBytes)
108−import Foreign.Ptr
109−import Foreign.Storable (poke)
110−import System.IO.Unsafe (unsafePerformIO)
111−
112−import Data.Bits
113−import Data.Word
114−import Control.Applicative
115−import Control.Monad (when,foldM_)
116−
117−import Prelude as P
118−import 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
170− deriving (Show)
171−
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)
281−
282−
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) }
287−
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'
292−
293−instance Functor BitGet where
294− fmap f m = m >>= \a -> return (f a)
295−
296−instance Applicative BitGet where
297− pure x = return x
298− fm <*> m = fm >>= \f -> m >>= \v -> return (f v)
299−
300−instance BitOrderable BitGet where
301− setBitOrder bo = do
302− (S bs o _) <- getState
303− putState (S bs o bo)
304−
305− getBitOrder = do
306− (S _ _ bo) <- getState
307− return bo
308−
309−instance Alignable BitGet where
310− -- | Skip the given number of bits
311− skipBits n = do
312− ensureBits n
313− withState (incS n)
314−
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)
320−
321−
322−
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
331−
332−mkInitState :: Get S
333−mkInitState = do
334− bs <- get
335− put B.empty
336− return (S bs 0 BB)
337−
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)
345−
346−getState :: BitGet S
347−getState = B $ \s -> return (s,s)
348−
349−putState :: S -> BitGet ()
350−putState s = B $ \_ -> return (s,())
351−
352−withState :: (S -> S) -> BitGet ()
353−withState f = do
354− s <- getState
355− putState $! f s
356−
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
380−
381−-- | Get 1 bit as a 'Bool'.
382−getBool# :: BitGet Int
383−getBool# = block bool#
384−
385−-- | Get @n@ bits as a 'Word8'. @n@ must be within @[0..8]@.
386−getWord8 :: Int -> BitGet Word8
387−getWord8 n = block (word8 n)
388−
389−-- | Get @n@ bits as a 'Word16'. @n@ must be within @[0..16]@.
390−getWord16 :: Int -> BitGet Word16
391−getWord16 n = block (word16 n)
392−
393−getWord16be :: Int -> BitGet Word16
394−getWord16be = getWord16
395−{-# DEPRECATED getWord16be "Use 'getWord16' instead" #-}
396−
397−-- | Get @n@ bits as a 'Word32'. @n@ must be within @[0..32]@.
398−getWord32 :: Int -> BitGet Word32
399−getWord32 n = block (word32 n)
400−
401−getWord32be :: Int -> BitGet Word32
402−getWord32be = getWord32
403−{-# DEPRECATED getWord32be "Use 'getWord32' instead" #-}
404−
405−-- | Get @n@ bits as a 'Word64'. @n@ must be within @[0..64]@.
406−getWord64 :: Int -> BitGet Word64
407−getWord64 n = block (word64 n)
408−
409−getWord64be :: Int -> BitGet Word64
410−getWord64be = getWord64
411−{-# DEPRECATED getWord64be "Use 'getWord64' instead" #-}
412−
413−-- | Get @n@ bytes as a 'ByteString'.
414−getByteString :: Int -> BitGet ByteString
415−getByteString n = block (byteString n)
416−
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
427−
428−
429−
430−
431−
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)
435−
436−instance Functor Block where
437− fmap f (Block i p) = Block i (\s -> f (p s))
438−
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
444−
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
455−
456−-- | Read a 1 bit 'Bool'.
457−bool :: Block Bool
458−bool = Block 1 readBool
459−
460−-- | Read a 1 bit 'Bool'.
461−bool# :: Block Int
462−bool# = Block 1 readBool#
463−
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)
467−
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)
471−
472−word16be :: Int -> Block Word16
473−word16be = word16
474−{-# DEPRECATED word16be "Use 'word16' instead" #-}
475−
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)
479−
480−word32be :: Int -> Block Word32
481−word32be = word32
482−{-# DEPRECATED word32be "Use 'word32' instead" #-}
483−
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)
487−
488−word64be :: Int -> Block Word64
489−word64be = word64
490−{-# DEPRECATED word64be "Use 'word64' instead" #-}
491−
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)
496−
Data/Binary/Bits/Internal.hsdeleted−176
@@ -1,176 +0,0 @@
1−{-# LANGUAGE RankNTypes, MagicHash, BangPatterns, CPP #-}
2−
3−-----------------------------------------------------------------------------
4−-- |
5−-- Module : Data.Binary.Bits.Get
6−-- Copyright : (c) Lennart Kolmodin 2010-2011
7−-- License : BSD3-style (see LICENSE)
8−--
9−-- Maintainer : kolmodin@gmail.com
10−-- Stability : experimental
11−-- Portability : portable (should run where the package binary runs)
12−
13−module Data.Binary.Bits.Internal
14− ( make_mask
15− , make_mask#
16− , mask
17− , mask#
18− , bit_offset
19− , byte_offset
20− , reverseBits
21− , reverseBits#
22− , FastBits(..)
23− )
24−where
25−
26−import Data.Word
27−import Data.Bits
28−
29−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
30−import GHC.Base
31−import GHC.Word
32−#endif
33−
34−-- | make_mask 3 = 00000111
35−make_mask :: (Bits a, Num a) => Int -> a
36−make_mask n = (1 `shiftL` fromIntegral n) - 1
37−{-# SPECIALIZE make_mask :: Int -> Int #-}
38−{-# SPECIALIZE make_mask :: Int -> Word #-}
39−{-# SPECIALIZE make_mask :: Int -> Word8 #-}
40−{-# SPECIALIZE make_mask :: Int -> Word16 #-}
41−{-# SPECIALIZE make_mask :: Int -> Word32 #-}
42−{-# SPECIALIZE make_mask :: Int -> Word64 #-}
43−
44−make_mask# :: Int# -> Word#
45−make_mask# n = (1## `shiftL#` n) `minusWord#` 1##
46−
47−-- | Keep only the n least-significant bits of the given value
48−mask :: (Bits a, Num a) => Int -> a -> a
49−mask n v = v .&. make_mask n
50−{-# INLINE mask #-}
51−
52−-- | Keep only the n least-significant bits of the given value
53−mask# :: Int# -> Word# -> Word#
54−mask# n v = v `and#` make_mask# n
55−
56−-- | Compute bit offset (equivalent to x `mod` 8 but faster)
57−bit_offset :: Int -> Int
58−bit_offset n = make_mask 3 .&. n
59−{-# INLINE bit_offset #-}
60−
61−-- | Compute byte offset (equivalent to x `div` 8 but faster)
62−byte_offset :: Int -> Int
63−byte_offset n = n `shiftR` 3
64−{-# INLINE byte_offset #-}
65−
66−-- | Reverse the @n@ least important bits of the given value
67−reverseBits :: (Num a, FastBits a, Bits a) => Int -> a -> a
68−reverseBits n value = rec value n 0
69− where
70− -- rec v i r, where
71− -- v is orginal value shifted
72− -- i is the remaining number of bits
73− -- r is current value
74− rec 0 0 r = r
75− rec 0 i r = r `fastShiftL` i
76− rec v i r = rec (v `fastShiftR` 1) (i-1) ((r `fastShiftL` 1) .|. (v .&. 0x1))
77−
78−reverseBits# :: Int# -> Word# -> Word#
79−reverseBits# n value = rec value n 0##
80− where
81− -- rec v i r, where
82− -- v is orginal value shifted
83− -- i is the remaining number of bits
84− -- r is current value
85− rec 0## 0# r = r
86− rec 0## i r = r `shiftL#` i
87− rec v i r = rec (v `shiftRL#` 1#) (i -# 1#) ((r `shiftL#` 1#) `or#` (v `and#` 0x1##))
88−
89−
90−---------------------------------------------------------------------
91−-- Unchecked shifts, from the "binary" package
92−
93−-- | Class for types supporting fast bit shifting
94−class Bits a => FastBits a where
95− fastShiftR :: a -> Int -> a
96− fastShiftR = shiftR
97−
98− fastShiftL :: a -> Int -> a
99− fastShiftL = shiftL
100−
101− {-# INLINE fastShift #-}
102− fastShift :: a -> Int -> a
103− fastShift x n
104− | n > 0 = fastShiftL x n
105− | n < 0 = fastShiftR x (negate n)
106− | otherwise = x
107−
108−instance FastBits Word8 where
109− fastShiftR = shiftr_w8
110− fastShiftL = shiftl_w8
111−
112−instance FastBits Word16 where
113− fastShiftR = shiftr_w16
114− fastShiftL = shiftl_w16
115−
116−instance FastBits Word32 where
117− fastShiftR = shiftr_w32
118− fastShiftL = shiftl_w32
119−
120−instance FastBits Word64 where
121− fastShiftR = shiftr_w64
122− fastShiftL = shiftl_w64
123−
124−instance FastBits Int
125−
126−instance FastBits Word
127−
128−
129−shiftl_w8 :: Word8 -> Int -> Word8
130−shiftl_w16 :: Word16 -> Int -> Word16
131−shiftl_w32 :: Word32 -> Int -> Word32
132−shiftl_w64 :: Word64 -> Int -> Word64
133−
134−shiftr_w8 :: Word8 -> Int -> Word8
135−shiftr_w16 :: Word16 -> Int -> Word16
136−shiftr_w32 :: Word32 -> Int -> Word32
137−shiftr_w64 :: Word64 -> Int -> Word64
138−
139−#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
140−shiftl_w8 w i = w `unsafeShiftL` i
141−shiftl_w16 w i = w `unsafeShiftL` i
142−shiftl_w32 w i = w `unsafeShiftL` i
143−
144−shiftr_w8 w i = w `unsafeShiftR` i
145−shiftr_w16 w i = w `unsafeShiftR` i
146−shiftr_w32 w i = w `unsafeShiftR` i
147−
148−
149−#if WORD_SIZE_IN_BITS < 64
150−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)
151−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)
152−
153−#if __GLASGOW_HASKELL__ <= 606
154−-- Exported by GHC.Word in GHC 6.8 and higher
155−foreign import ccall unsafe "stg_uncheckedShiftL64"
156− uncheckedShiftL64# :: Word64# -> Int# -> Word64#
157−foreign import ccall unsafe "stg_uncheckedShiftRL64"
158− uncheckedShiftRL64# :: Word64# -> Int# -> Word64#
159−#endif
160−
161−#else
162−shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)
163−shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)
164−#endif
165−
166−#else
167−shiftl_w8 = shiftL
168−shiftl_w16 = shiftL
169−shiftl_w32 = shiftL
170−shiftl_w64 = shiftL
171−
172−shiftr_w8 = shiftR
173−shiftr_w16 = shiftR
174−shiftr_w32 = shiftR
175−shiftr_w64 = shiftR
176−#endif
Data/Binary/Bits/Put.hsdeleted−285
@@ -1,285 +0,0 @@
1−{-# LANGUAGE MagicHash #-}
2−
3−-----------------------------------------------------------------------------
4−-- |
5−-- Module : Data.Binary.Bits.Put
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−-- Put bits easily.
15−-----------------------------------------------------------------------------
16−
17−module Data.Binary.Bits.Put
18− ( BitPut
19− , runBitPut
20− , joinPut
21−
22− -- * Data types
23− -- ** Bool
24− , putBool
25− , putBool#
26−
27− -- ** Words
28− , putWord#
29− , putWord8
30− , putWord16
31− , putWord32
32− , putWord64
33− , putWord16be
34− , putWord32be
35− , putWord64be
36−
37− -- ** ByteString
38− , putByteString
39− )
40− where
41−
42−import qualified Data.Binary.Builder as B
43−import Data.Binary.Builder ( Builder )
44−import qualified Data.Binary.Put as Put
45−import Data.Binary.Put ( Put )
46−import Data.Binary.Bits.Internal
47−import Data.Binary.Bits.BitOrder
48−import Data.Binary.Bits.Alignment
49−
50−import Data.ByteString as BS
51−import Data.ByteString.Unsafe as BS
52−
53−import Control.Monad (when)
54−import Data.Bits
55−import Data.Word
56−import GHC.Base (Word#, shiftRL#, Int (..), Int#, (-#), (<#), isTrue#, (+#), shiftL#, wordToWord8#, orWord8#)
57−import GHC.Word (Word8(..))
58−
59−data BitPut a = BitPut { run :: (S -> PairS a) }
60−
61−data PairS a = PairS a {-# UNPACK #-} !S
62−
63−data S = S !Builder !Word8 !Int !BitOrder
64−
65−-- | Put a 1 bit 'Bool'.
66−putBool :: Bool -> BitPut ()
67−putBool b = putWord8 1 (if b then 0xff else 0x00)
68−
69−-- | Put a 1 bit 'Bool'.
70−putBool# :: Word# -> BitPut ()
71−putBool# b = putWord# 1# b
72−
73−
74−-- | Generic putWord
75−putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()
76−putWord n w = BitPut $ \s -> PairS () (putWordS n w s)
77−
78−putWord# :: Int# -> Word# -> BitPut ()
79−putWord# n w = BitPut $ \s -> PairS () (putWordS# n w s)
80−
81−putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S
82−putWordS n w s@(S builder b o bo) = s'
83− where
84− -- number of bits that will be stored in the current byte
85− cn = min (8-o) n
86−
87− -- new state
88− s' = case n of
89− 0 -> s
90− _ -> putWordS (n-cn) w' (flush (S builder b' (o+cn) bo))
91−
92− -- new current byte
93− b' = shl (selectBits w) .|. b
94−
95− -- Word containing the remaining (n-cn) bits to store in its LSB
96− w' = case bo of
97− BB -> w
98− BL -> w `fastShiftR` cn
99− LL -> w `fastShiftR` cn
100− LB -> w
101−
102− -- Select bits to store in the current byte.
103− -- Put them in the correct order and return them in the least-significant
104− -- bits of the returned value
105− selectBits :: (Num a, FastBits a, Integral a) => a -> Word8
106− selectBits x = fromIntegral $ case bo of
107− BB -> mask cn $ x `fastShiftR` (n-cn)
108− LB -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)
109− LL -> mask cn x
110− BL -> reverseBits cn $ mask cn x
111−
112− -- shift left at the correct position
113− shl :: Word8 -> Word8
114− shl x = case bo of
115− BB -> x `fastShiftL` (8-o-cn)
116− BL -> x `fastShiftL` (8-o-cn)
117− LL -> x `fastShiftL` o
118− LB -> x `fastShiftL` o
119−
120− flush s2@(S b2 w2 o2 bo2)
121− | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
122− | otherwise = s2
123−
124−putWordS# :: Int# -> Word# -> S -> S
125−putWordS# n w s@(S builder (W8# b) (I# o) bo) = s'
126− where
127− min# :: Int# -> Int# -> Int#
128− min# x y | isTrue# (x <# y) = x
129− min# _ y = y
130−
131− -- number of bits that will be stored in the current byte
132− cn = min# (8# -# o) n
133−
134− -- new state
135− s' = case n of
136− 0# -> s
137− _ -> putWordS# (n -# cn) w' (flush (S builder (W8# b') (I# (o +# cn)) bo))
138−
139− -- new current byte
140− b' = wordToWord8# (shl (selectBits w)) `orWord8#` b
141−
142− -- Word containing the remaining (n-cn) bits to store in its LSB
143− w' = case bo of
144− BB -> w
145− BL -> w `shiftRL#` cn
146− LL -> w `shiftRL#` cn
147− LB -> w
148−
149− -- Select bits to store in the current byte.
150− -- Put them in the correct order and return them in the least-significant
151− -- bits of the returned value
152− selectBits :: Word# -> Word#
153− selectBits x = case bo of
154− BB -> mask# cn (x `shiftRL#` (n -# cn))
155− LB -> reverseBits# cn (mask# cn (x `shiftRL#` (n -# cn)))
156− LL -> mask# cn x
157− BL -> reverseBits# cn (mask# cn x)
158−
159− -- shift left at the correct position
160− shl :: Word# -> Word#
161− shl x = case bo of
162− BB -> x `shiftL#` (8# -# o -# cn)
163− BL -> x `shiftL#` (8# -# o -# cn)
164− LL -> x `shiftL#` o
165− LB -> x `shiftL#` o
166−
167− flush s2@(S b2 w2 o2 bo2)
168− | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
169− | otherwise = s2
170−
171−
172−-- | Put the @n@ lower bits of a 'Word8'.
173−putWord8 :: Int -> Word8 -> BitPut ()
174−putWord8 = putWord
175−
176−-- | Put the @n@ lower bits of a 'Word16'.
177−putWord16 :: Int -> Word16 -> BitPut ()
178−putWord16 = putWord
179−
180−putWord16be :: Int -> Word16 -> BitPut ()
181−putWord16be = putWord
182−{-# DEPRECATED putWord16be "Use 'putWord16' instead" #-}
183−
184−-- | Put the @n@ lower bits of a 'Word32'.
185−putWord32 :: Int -> Word32 -> BitPut ()
186−putWord32 = putWord
187−
188−putWord32be :: Int -> Word32 -> BitPut ()
189−putWord32be = putWord
190−{-# DEPRECATED putWord32be "Use 'putWord32' instead" #-}
191−
192−-- | Put the @n@ lower bits of a 'Word64'.
193−putWord64 :: Int -> Word64 -> BitPut ()
194−putWord64 = putWord
195−
196−putWord64be :: Int -> Word64 -> BitPut ()
197−putWord64be = putWord
198−{-# DEPRECATED putWord64be "Use 'putWord64' instead" #-}
199−
200−-- | Put a 'ByteString'.
201−--
202−-- Examples: 3 bits are already written in the current byte
203−-- BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx
204−-- LL: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC
205−-- BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx
206−-- LB: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON
207−putByteString :: ByteString -> BitPut ()
208−putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
209−
210−putByteStringS :: ByteString -> S -> S
211−putByteStringS bs s
212− | BS.null bs = s
213− | otherwise = case s of
214− (S builder b 0 BB) -> S (builder `mappend` B.fromByteString bs) b 0 BB
215− (S builder b 0 LL) -> S (builder `mappend` B.fromByteString (BS.reverse bs)) b 0 LL
216− (S builder b 0 LB) -> S (builder `mappend` B.fromByteString (rev bs)) b 0 LB
217− (S builder b 0 BL) -> S (builder `mappend` B.fromByteString (rev (BS.reverse bs))) b 0 BL
218− (S _ _ _ BB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
219− (S _ _ _ LL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
220− (S _ _ _ BL) -> putByteStringS (BS.unsafeInit bs) (putWordS 8 (BS.unsafeLast bs) s)
221− (S _ _ _ LB) -> putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
222− where
223− rev = BS.map (reverseBits 8)
224−
225−
226−-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
227−-- before 'Put' executes to ensure byte alignment.
228−--
229−-- Warning: this method does not take bit order into account (i.e. BB assumed)
230−joinPut :: Put -> BitPut ()
231−joinPut m = BitPut $ \s0 -> PairS () $
232− let (S b0 _ _ bo) = flushIncomplete s0
233− b = Put.execPut m
234− in (S (b0`mappend`b) 0 0 bo)
235−
236−flushIncomplete :: S -> S
237−flushIncomplete s@(S b w o bo)
238− | o == 0 = s
239− | otherwise = (S (b `mappend` B.singleton w) 0 0 bo)
240−
241−getOffset :: BitPut Int
242−getOffset = BitPut $ \s@(S _ _ o _) -> PairS o s
243−
244−-- | Run the 'BitPut' monad inside 'Put'.
245−runBitPut :: BitPut () -> Put.Put
246−runBitPut m = Put.putBuilder b
247− where
248− PairS _ s = run m (S mempty 0 0 BB)
249− (S b _ _ _) = flushIncomplete s
250−
251−instance Functor BitPut where
252− fmap f (BitPut k) = BitPut $ \s ->
253− let PairS x s' = k s
254− in PairS (f x) s'
255−
256−instance Applicative BitPut where
257− pure a = BitPut (\s -> PairS a s)
258− (BitPut f) <*> (BitPut g) = BitPut $ \s ->
259− let PairS a s' = f s
260− PairS b s'' = g s'
261− in PairS (a b) s''
262−
263−instance Monad BitPut where
264− m >>= k = BitPut $ \s ->
265− let PairS a s' = run m s
266− PairS b s'' = run (k a) s'
267− in PairS b s''
268− return x = BitPut $ \s -> PairS x s
269−
270−instance BitOrderable BitPut where
271− setBitOrder bo = BitPut $ \(S bu b o _) -> PairS () (S bu b o bo)
272−
273− getBitOrder = BitPut $ \s@(S _ _ _ bo) -> PairS bo s
274−
275−instance Alignable BitPut where
276− -- | Skip the given number of bits
277− skipBits n
278− | n <= 64 = putWord64 n 0
279− | otherwise = putWord64 64 0 >> skipBits (n-64)
280−
281− -- | Skip bits if necessary to align to the next byte
282− alignByte = do
283− o <- getOffset
284− when (o /= 0) $
285− skipBits (8-o)
LICENSE+22−22
@@ -1,30 +1,30 @@
1−Copyright (c) Lennart Kolmodin
1+Copyright (c)2010, Lennart Kolmodin
2
2
3All rights reserved.
3All rights reserved.
4
4
5Redistribution and use in source and binary forms, with or without
5Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions
6+modification, are permitted provided that the following conditions are met:
7−are met:
8
7
9−1. Redistributions of source code must retain the above copyright
8+ * Redistributions of source code must retain the above copyright
10− notice, this list of conditions and the following disclaimer.
9+ notice, this list of conditions and the following disclaimer.
11
10
12−2. Redistributions in binary form must reproduce the above copyright
11+ * Redistributions in binary form must reproduce the above
13− notice, this list of conditions and the following disclaimer in the
12+ copyright notice, this list of conditions and the following
14− documentation and/or other materials provided with the distribution.
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15
15
16−3. Neither the name of the author nor the names of his contributors
16+ * Neither the name of Lennart Kolmodin nor the names of other
17− may be used to endorse or promote products derived from this software
17+ contributors may be used to endorse or promote products derived
18− without specific prior written permission.
18+ from this software without specific prior written permission.
19
19
20−THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
24−ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
25−DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
26−OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
27−HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
28−STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29−ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30−POSSIBILITY OF SUCH DAMAGE.
binary-bits.cabal+21−31
@@ -1,48 +1,38 @@
1−-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/
1+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
2name: binary-bits
2name: binary-bits
3−version: 0.6
3+version: 0.1
4−synopsis: Bit parsing/writing on top of binary.
4+synopsis: Bit parsing on top of binary.
5−description: Bit parsing/writing on top of binary. Provides functions to
5+description: Bit parsing on top of binary. Provides functions to
6− read and write bits to and from 8\/16\/32\/64 words.
6+ read parts of 8/16/32/64 words.
7license: BSD3
7license: BSD3
8license-file: LICENSE
8license-file: LICENSE
9−author: Lennart Kolmodin <kolmodin@gmail.com>
9+author: Lennart Kolmodin <kolmodin@gentoo.org>
10−maintainer: Lennart Kolmodin <kolmodin@gmail.com>
10+maintainer: Lennart Kolmodin <kolmodin@gentoo.org>
11+-- copyright:
11−category: Data, Parsing
12+category: Data
12build-type: Simple
13build-type: Simple
14+-- Extra files to be distributed with the package, such as examples or
15+-- a README.
16+-- extra-source-files:
13
17
18+-- Constraint on the version of Cabal needed to build this package.
14−cabal-version: >=1.10
19+cabal-version: >=1.8
15
20
16−source-repository head
17− type: git
18− location: git://github.com/kolmodin/binary-bits.git
19
21
20library
22library
21− build-depends: base==4.*, binary >= 0.6.0.0, bytestring
23+ exposed-modules: BitsGet, BitsPut, Bits
22
24
23− other-extensions: RankNTypes, MagicHash, BangPatterns, CPP
25+ build-depends: base==4.*, binary, bytestring
24−
25− exposed-modules: Data.Binary.Bits ,
26− Data.Binary.Bits.Put ,
27− Data.Binary.Bits.Get ,
28− Data.Binary.Bits.BitOrder ,
29− Data.Binary.Bits.Alignment
30− other-modules: Data.Binary.Bits.Internal
26+ -- other-modules:
31−
27+ -- build-tools:
32− default-language: Haskell98
33−
34− ghc-options: -O2 -Wall
35
28
36test-suite qc
29test-suite qc
37 type: exitcode-stdio-1.0
30 type: exitcode-stdio-1.0
38 main-is: BitsQC.hs
31 main-is: BitsQC.hs
39− default-language: Haskell98
40− --ghc-options: -O2 -Wall
41
32
33+ build-depends: binary-bits, binary,
42− build-depends: base==4.*, binary >= 0.6.0.0, bytestring,
34+ base==4.*, haskell98, bytestring,
43 QuickCheck>=2, random,
35 QuickCheck>=2, random,
44 test-framework,
36 test-framework,
45 test-framework-quickcheck2
37 test-framework-quickcheck2
46−
38+ ghc-options: -fhpc
47− other-extensions: RankNTypes, MagicHash, BangPatterns, CPP,
48− FlexibleInstances, FlexibleContexts, TupleSections
flake.lockdeleted−59
@@ -1,59 +0,0 @@
1−{
2− "nodes": {
3− "flake-utils": {
4− "inputs": {
5− "systems": "systems"
6− },
7− "locked": {
8− "lastModified": 1731533236,
9− "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=",
10− "owner": "numtide",
11− "repo": "flake-utils",
12− "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b",
13− "type": "github"
14− },
15− "original": {
16− "id": "flake-utils",
17− "type": "indirect"
18− }
19− },
20− "nixpkgs": {
21− "locked": {
22− "lastModified": 1737469691,
23− "narHash": "sha256-nmKOgAU48S41dTPIXAq0AHZSehWUn6ZPrUKijHAMmIk=",
24− "owner": "NixOS",
25− "repo": "nixpkgs",
26− "rev": "9e4d5190a9482a1fb9d18adf0bdb83c6e506eaab",
27− "type": "github"
28− },
29− "original": {
30− "id": "nixpkgs",
31− "ref": "nixos-unstable",
32− "type": "indirect"
33− }
34− },
35− "root": {
36− "inputs": {
37− "flake-utils": "flake-utils",
38− "nixpkgs": "nixpkgs"
39− }
40− },
41− "systems": {
42− "locked": {
43− "lastModified": 1681028828,
44− "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
45− "owner": "nix-systems",
46− "repo": "default",
47− "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
48− "type": "github"
49− },
50− "original": {
51− "owner": "nix-systems",
52− "repo": "default",
53− "type": "github"
54− }
55− }
56− },
57− "root": "root",
58− "version": 7
59−}
flake.nixdeleted−24
@@ -1,24 +0,0 @@
1−{
2− inputs = {
3− nixpkgs.url = "nixpkgs/nixos-unstable";
4− flake-utils.url = "flake-utils";
5− };
6−
7− outputs = { self, flake-utils, nixpkgs }:
8− let
9− supportedSystems =
10− [ "x86_64-linux" "x86_64-darwin" "aarch64-darwin" "aarch64-linux" ];
11− compilerVersion = "966";
12− in flake-utils.lib.eachSystem supportedSystems (system:
13− let pkgs = import nixpkgs { inherit system; };
14− in {
15− devShells.default = pkgs.mkShell {
16− buildInputs = with pkgs; [
17− haskell.compiler."ghc${compilerVersion}"
18− (pkgs.haskell-language-server.override {
19− supportedGhcVersions = [ compilerVersion ];
20− })
21− ];
22− };
23− });
24−}
stack.yamldeleted−66
@@ -1,66 +0,0 @@
1−# This file was automatically generated by 'stack init'
2−#
3−# Some commonly used options have been documented as comments in this file.
4−# For advanced use and comprehensive documentation of the format, please see:
5−# https://docs.haskellstack.org/en/stable/yaml_configuration/
6−
7−# Resolver to choose a 'specific' stackage snapshot or a compiler version.
8−# A snapshot resolver dictates the compiler version and the set of packages
9−# to be used for project dependencies. For example:
10−#
11−# resolver: lts-3.5
12−# resolver: nightly-2015-09-21
13−# resolver: ghc-7.10.2
14−#
15−# The location of a snapshot can be provided as a file or url. Stack assumes
16−# a snapshot provided as a file might change, whereas a url resource does not.
17−#
18−# resolver: ./custom-snapshot.yaml
19−# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-22.43
21−
22−# User packages to be built.
23−# Various formats can be used as shown in the example below.
24−#
25−# packages:
26−# - some-directory
27−# - https://example.com/foo/bar/baz-0.0.2.tar.gz
28−# subdirs:
29−# - auto-update
30−# - wai
31−packages:
32−- .
33−# Dependency packages to be pulled from upstream that are not in the resolver.
34−# These entries can reference officially published versions as well as
35−# forks / in-progress versions pinned to a git hash. For example:
36−#
37−# extra-deps:
38−# - acme-missiles-0.3
39−# - git: https://github.com/commercialhaskell/stack.git
40−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
41−#
42−# extra-deps: []
43−
44−# Override default flag values for local packages and extra-deps
45−# flags: {}
46−
47−# Extra package databases containing global packages
48−# extra-package-dbs: []
49−
50−# Control whether we use the GHC we find on the path
51−# system-ghc: true
52−#
53−# Require a specific version of stack, using version ranges
54−# require-stack-version: -any # Default
55−# require-stack-version: ">=2.9"
56−#
57−# Override the architecture used by stack, especially useful on Windows
58−# arch: i386
59−# arch: x86_64
60−#
61−# Extra directories used by stack for building
62−# extra-include-dirs: [/path/to/dir]
63−# extra-lib-dirs: [/path/to/dir]
64−#
65−# Allow a newer minor version of GHC than the snapshot specifies
66−# compiler-check: newer-minor
stack.yaml.lockdeleted−12
@@ -1,12 +0,0 @@
1−# This file was autogenerated by Stack.
2−# You should not edit this file by hand.
3−# For more information, please see the documentation at:
4−# https://docs.haskellstack.org/en/stable/lock_files
5−
6−packages: []
7−snapshots:
8−- completed:
9− sha256: 08bd13ce621b41a8f5e51456b38d5b46d7783ce114a50ab604d6bbab0d002146
10− size: 720271
11− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/22/43.yaml
12− original: lts-22.43