git.iko.soy/binary-bits
on master help sign in
swap
21adca790 ahead, 0 behind
18 files changed+1720−750
since splitsnapshots
unifiedsplit
.gitignore+4 .travis.yml+41 Bits.hs−30 BitsGet.hs−424 BitsPut.hs−115 BitsQC.hs+390−138 Data/Binary/Bits.hs+45 Data/Binary/Bits/Alignment.hs+22 Data/Binary/Bits/BitOrder.hs+47 Data/Binary/Bits/Get.hs+496 Data/Binary/Bits/Internal.hs+176 Data/Binary/Bits/Put.hs+285 LICENSE+22−22 binary-bits.cabal+31−21 flake.lock+59 flake.nix+24 stack.yaml+66 stack.yaml.lock+12
.gitignorenew file+4
@@ -0,0 +1,4 @@
1+.cabal-sandbox
2+cabal.sandbox.config
3+dist/
4+.stack-work
.travis.ymlnew file+41
@@ -0,0 +1,41 @@
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.hsdeleted−30
@@ -1,30 +0,0 @@
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.hsdeleted−424
@@ -1,424 +0,0 @@
1−{-# LANGUAGE 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.hsdeleted−115
@@ -1,115 +0,0 @@
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+390−138
@@ -1,43 +1,33 @@
1−module Main where
1+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, TupleSections #-}
22
3−import Data.Binary ( encode, Binary(..) )
4−import Data.Binary.Get ( runGet )
3+module Main ( main ) where
4+
5+import Data.Binary ( Binary(..) )
6+import Data.Binary.Get ( runGet, runGetIncremental, pushChunks, Decoder(..) )
57import Data.Binary.Put ( runPut )
68
7−import qualified Data.Binary.Get as BG ( getWord8, getWord16be, getWord32be, getWord64be )
8−import qualified Data.Binary.Put as BP ( putWord8, putWord16be, putWord32be, putWord64be )
9+import Data.Binary.Bits
10+import Data.Binary.Bits.Get
11+import Data.Binary.Bits.Put
12+import Data.Binary.Bits.BitOrder
913
10−import Bits
14+import qualified Data.ByteString as B
15+import qualified Data.ByteString.Lazy as L
1116
17+import Control.Applicative
1218import Data.Bits
13−import Data.Monoid
1419import Data.Word
1520import Foreign.Storable
16−import System.Random
17−import System
18−
19−import BitsGet
20−import BitsPut
21+import Data.Traversable (traverse)
22+import Data.Foldable (traverse_)
2123
22−import Test.Framework.Options ( TestOptions'(..) )
2324import Test.Framework.Providers.QuickCheck2 ( testProperty )
24−import Test.Framework.Runners.Console ( defaultMainWithOpts )
25−import Test.Framework.Runners.Options ( RunnerOptions'(..) )
25+import Test.Framework.Runners.Console ( defaultMain )
2626import Test.Framework ( Test, testGroup )
2727import Test.QuickCheck
2828
29−main = do
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− }
29+main :: IO ()
30+main = defaultMain tests
4131
4232tests :: [Test]
4333tests =
@@ -47,101 +37,196 @@ tests =
4737 , testGroup "Custom test cases"
4838 [ testProperty "prop_composite_case" prop_composite_case ]
4939
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+
5063 , testGroup "prop_bitput_with_get_from_binary"
51− [ testProperty "Word8" (prop_bitput_with_get_from_binary :: [Word8] -> Property)
52− , testProperty "Word16" (prop_bitput_with_get_from_binary :: [Word16] -> Property)
53− , testProperty "Word32" (prop_bitput_with_get_from_binary :: [Word32] -> Property)
54− , testProperty "Word64" (prop_bitput_with_get_from_binary :: [Word64] -> Property)
64+ [ testProperty "Word8" (prop_bitput_with_get_from_binary :: W [Word8] -> Property)
65+ , testProperty "Word16" (prop_bitput_with_get_from_binary :: W [Word16] -> Property)
66+ , testProperty "Word32" (prop_bitput_with_get_from_binary :: W [Word32] -> Property)
67+ , testProperty "Word64" (prop_bitput_with_get_from_binary :: W [Word64] -> Property)
5568 ]
5669
5770 , testGroup "prop_bitget_with_put_from_binary"
58− [ testProperty "Word8" (prop_bitget_with_put_from_binary :: [Word8] -> Property)
59− , testProperty "Word16" (prop_bitget_with_put_from_binary :: [Word16] -> Property)
60− , testProperty "Word32" (prop_bitget_with_put_from_binary :: [Word32] -> Property)
61− , testProperty "Word64" (prop_bitget_with_put_from_binary :: [Word64] -> Property)
71+ [ testProperty "Word8" (prop_bitget_with_put_from_binary :: W [Word8] -> Property)
72+ , testProperty "Word16" (prop_bitget_with_put_from_binary :: W [Word16] -> Property)
73+ , testProperty "Word32" (prop_bitget_with_put_from_binary :: W [Word32] -> Property)
74+ , testProperty "Word64" (prop_bitget_with_put_from_binary :: W [Word64] -> Property)
6275 ]
6376
6477 , testGroup "prop_compare_put_with_naive"
65− [ testProperty "Word8" (prop_compare_put_with_naive :: [Word8] -> Property)
66− , testProperty "Word16" (prop_compare_put_with_naive :: [Word16] -> Property)
67− , testProperty "Word32" (prop_compare_put_with_naive :: [Word32] -> Property)
68− , testProperty "Word64" (prop_compare_put_with_naive :: [Word64] -> Property)
78+ [ testProperty "Word8" (prop_compare_put_with_naive :: W [Word8] -> Property)
79+ , testProperty "Word16" (prop_compare_put_with_naive :: W [Word16] -> Property)
80+ , testProperty "Word32" (prop_compare_put_with_naive :: W [Word32] -> Property)
81+ , testProperty "Word64" (prop_compare_put_with_naive :: W [Word64] -> Property)
6982 ]
7083
7184 , testGroup "prop_compare_get_with_naive"
72− [ testProperty "Word8" (prop_compare_get_with_naive:: [Word8] -> Property)
73− , testProperty "Word16" (prop_compare_get_with_naive:: [Word16] -> Property)
74− , testProperty "Word32" (prop_compare_get_with_naive:: [Word32] -> Property)
75− , testProperty "Word64" (prop_compare_get_with_naive:: [Word64] -> Property)
85+ [ testProperty "Word8" (prop_compare_get_with_naive:: W [Word8] -> Property)
86+ , testProperty "Word16" (prop_compare_get_with_naive:: W [Word16] -> Property)
87+ , testProperty "Word32" (prop_compare_get_with_naive:: W [Word32] -> Property)
88+ , testProperty "Word64" (prop_compare_get_with_naive:: W [Word64] -> Property)
7689 ]
7790
7891 , testGroup "prop_put_with_bitreq"
79− [ testProperty "Word8" (prop_putget_with_bitreq :: Word8 -> Property)
80− , testProperty "Word16" (prop_putget_with_bitreq :: Word16 -> Property)
81− , testProperty "Word32" (prop_putget_with_bitreq :: Word32 -> Property)
82− , testProperty "Word64" (prop_putget_with_bitreq :: Word64 -> Property)
92+ [ testProperty "Word8" (prop_putget_with_bitreq :: BitOrder -> W Word8 -> Property)
93+ , testProperty "Word16" (prop_putget_with_bitreq :: BitOrder -> W Word16 -> Property)
94+ , testProperty "Word32" (prop_putget_with_bitreq :: BitOrder -> W Word32 -> Property)
95+ , testProperty "Word64" (prop_putget_with_bitreq :: BitOrder -> W Word64 -> Property)
8396 ]
8497
8598 , testGroup "prop_putget_list_simple"
86− [ testProperty "Bool" (prop_putget_list_simple :: [Bool] -> Property)
87− , testProperty "Word8" (prop_putget_list_simple :: [Word8] -> Property)
88− , testProperty "Word16" (prop_putget_list_simple :: [Word16] -> Property)
89− , testProperty "Word32" (prop_putget_list_simple :: [Word32] -> Property)
90− , testProperty "Word64" (prop_putget_list_simple :: [Word64] -> Property)
99+ [ testProperty "Bool" (prop_putget_list_simple :: W [Bool] -> Property)
100+ , testProperty "Word8" (prop_putget_list_simple :: W [Word8] -> Property)
101+ , testProperty "Word16" (prop_putget_list_simple :: W [Word16] -> Property)
102+ , testProperty "Word32" (prop_putget_list_simple :: W [Word32] -> Property)
103+ , testProperty "Word64" (prop_putget_list_simple :: W [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)
91111 ]
92112
93113 , testGroup "prop_putget_list_with_bitreq"
94− [ testProperty "Word8" (prop_putget_list_with_bitreq :: [Word8] -> Property)
95− , testProperty "Word16" (prop_putget_list_with_bitreq :: [Word16] -> Property)
96− , testProperty "Word32" (prop_putget_list_with_bitreq :: [Word32] -> Property)
97− , testProperty "Word64" (prop_putget_list_with_bitreq :: [Word64] -> Property)
114+ [ testProperty "Word8" (prop_putget_list_with_bitreq :: W [Word8] -> Property)
115+ , testProperty "Word16" (prop_putget_list_with_bitreq :: W [Word16] -> Property)
116+ , testProperty "Word32" (prop_putget_list_with_bitreq :: W [Word32] -> Property)
117+ , testProperty "Word64" (prop_putget_list_with_bitreq :: W [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
98128 ]
99129 ]
100130
101−{-
102− -- these tests use the R structure
103− --
104− -- quickCheck prop_Word32_from_2_Word16
105− -- quickCheck prop_Word32_from_Word8_and_Word16
106−-}
107−
108−prop_putget_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => a -> Property
109−prop_putget_with_bitreq w = property $
131+prop_isEmptyOfEmptyEmpty :: Bool
132+prop_isEmptyOfEmptyEmpty = runGet (runBitGet isEmpty) L.empty
133+
134+prop_isEmptyOfNonEmptyEmpty :: L.ByteString -> Property
135+prop_isEmptyOfNonEmptyEmpty bs =
136+ not (L.null bs) ==> not (runGet (runBitGet isEmpty) bs)
137+
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
182+prop_putget_with_bitreq bo (W w) = property $
110183 -- write all words with as many bits as it's required
111184 let p = putBits (bitreq w) w
112185 g = getBits (bitreq w)
113− lbs = runPut (runBitPut p)
114− w' = runGet (runBitGetSimple g) lbs
186+ lbs = runPut (runBitPut (withBitOrder bo p))
187+ w' = runGet (runBitGet (withBitOrder bo g)) lbs
115188 in w == w'
116189
117190-- | Write a list of items. Each item is written with the maximum amount of
118191-- bits, i.e. 8 for Word8, 16 for Word16, etc.
119−prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => [a] -> Property
120−prop_putget_list_simple ws = property $
192+prop_putget_list_simple :: (BinaryBit a, Eq a, Storable a) => W [a] -> Property
193+prop_putget_list_simple (W ws) = property $
121194 let s = sizeOf (head ws) * 8
122− p = mapM_ (\v -> putBits s v) ws
195+ p = mapM_ (putBits s) ws
123196 g = mapM (const (getBits s)) ws
124197 lbs = runPut (runBitPut p)
125− ws' = runGet (runBitGetSimple g) lbs
198+ ws' = runGet (runBitGet g) lbs
126199 in ws == ws'
127200
128201-- | Write a list of items. Each item is written with exactly as many bits
129202-- as required. Then read it back.
130−prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => [a] -> Property
131−prop_putget_list_with_bitreq ws = property $
203+prop_putget_list_with_bitreq :: (BinaryBit a, Num a, Bits a, Ord a) => W [a] -> Property
204+prop_putget_list_with_bitreq (W ws) = property $
132205 -- write all words with as many bits as it's required
133206 let p = mapM_ (\v -> putBits (bitreq v) v) ws
134207 g = mapM getBits bitlist
135208 lbs = runPut (runBitPut p)
136− ws' = runGet (runBitGetSimple g) lbs
209+ ws' = runGet (runBitGet g) lbs
137210 in ws == ws'
138211 where
139212 bitlist = map bitreq ws
140213
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+
141226-- | Write bits using this library, and read them back using the binary
142227-- library.
143−prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
144−prop_bitput_with_get_from_binary ws = property $
228+prop_bitput_with_get_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
229+prop_bitput_with_get_from_binary (W ws) = property $
145230 let s = sizeOf (head ws) * 8
146231 p = mapM_ (putBits s) ws
147232 g = mapM (const get) ws
@@ -151,61 +236,88 @@ prop_bitput_with_get_from_binary ws = property $
151236
152237-- | Write bits using the binary library, and read them back using this
153238-- library.
154−prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => [a] -> Property
155−prop_bitget_with_put_from_binary ws = property $
239+prop_bitget_with_put_from_binary :: (BinaryBit a, Binary a, Storable a, Eq a) => W [a] -> Property
240+prop_bitget_with_put_from_binary (W ws) = property $
156241 let s = sizeOf (head ws) * 8
157242 p = mapM_ put ws
158243 g = mapM (const (getBits s)) ws
159244 lbs = runPut p
160− ws' = runGet (runBitGetSimple g) lbs
245+ ws' = runGet (runBitGet g) lbs
161246 in ws == ws'
162247
163−-- number of bits required to write 'v'
164−bitreq :: (Num b, Bits a, Ord a) => a -> b
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@
277+bitreq :: (Num b, Num a, Bits a, Ord a) => a -> b
165278bitreq v = fromIntegral . head $ [ req | (req, top) <- bittable, v <= top ]
166279
167−bittable :: Bits a => [(Integer, a)]
280+bittable :: (Bits a, Num a) => [(Integer, a)]
168281bittable = [ (fromIntegral x, (1 `shiftL` x) - 1) | x <- [1..64] ]
169282
170−prop_bitreq :: Word64 -> Property
171−prop_bitreq w = property $
283+prop_bitreq :: W Word64 -> Property
284+prop_bitreq (W w) = property $
172285 ( w == 0 && bitreq w == 1 )
173− || bitreq w == (bitreq (w `shiftR` 1)) + 1
286+ || bitreq w == bitreq (w `shiftR` 1) + 1
174287
175−prop_composite_case :: Bool -> Word16 -> Property
176−prop_composite_case b w = w < 0x8000 ==>
288+prop_composite_case :: Bool -> W Word16 -> Property
289+prop_composite_case b (W w) = w < 0x8000 ==>
177290 let p = do putBool b
178− putWord16be 15 w
291+ putWord16 15 w
179292 g = do v <- getBool
180293 case v of
181− True -> getWord16be 15
294+ True -> getWord16 15
182295 False -> do
183296 msb <- getWord8 7
184297 lsb <- getWord8 8
185298 return ((fromIntegral msb `shiftL` 8) .|. fromIntegral lsb)
186299 lbs = runPut (runBitPut p)
187− w' = runGet (runBitGetSimple g) lbs
300+ w' = runGet (runBitGet g) lbs
188301 in w == w'
189302
190−
191−prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a) => [a] -> Property
192−prop_compare_put_with_naive ws = property $
303+prop_compare_put_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
304+prop_compare_put_with_naive (W ws) = property $
193305 let pn = mapM_ (\v -> naive_put (bitreq v) v) ws
194306 p = mapM_ (\v -> putBits (bitreq v) v) ws
195307 lbs_n = runPut (runBitPut pn)
196308 lbs = runPut (runBitPut p)
197309 in lbs_n == lbs
198310
199−prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => [a] -> Property
200−prop_compare_get_with_naive ws = property $
311+prop_compare_get_with_naive :: (Bits a, BinaryBit a, Ord a, Num a) => W [a] -> Property
312+prop_compare_get_with_naive (W ws) = property $
201313 let gn = mapM (\v -> naive_get (bitreq v)) ws
202314 g = mapM (\v -> getBits (bitreq v)) ws
203315 p = mapM_ (\v -> naive_put (bitreq v) v) ws
204316 lbs = runPut (runBitPut p)
205− rn = runGet (runBitGetSimple gn) lbs
206− r = runGet (runBitGetSimple g ) lbs
317+ rn = runGet (runBitGet gn) lbs
318+ r = runGet (runBitGet g ) lbs
207319 -- we must help our compiler to resolve the types of 'gn' and 'g'
208− types = rn == ws && r == ws
320+ _types = rn == ws && r == ws
209321 in rn == r
210322
211323-- | Write one bit at a time until the full word has been written
@@ -223,27 +335,6 @@ naive_get n0 =
223335 True -> loop (n-1) ((acc `shiftL` 1) + 1)
224336 in loop n0 0
225337
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−
247338shrinker :: (Num a, Ord a, Bits a) => a -> [a]
248339shrinker 0 = []
249340shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
@@ -255,27 +346,187 @@ shrinker w = [ w `shiftR` 1 -- try to make everything roughly half size
255346 where
256347 n = bitreq w
257348
258−instance Arbitrary Word8 where
259− arbitrary = choose (minBound, maxBound)
260− shrink = shrinker
261−
262−instance Arbitrary Word16 where
263− arbitrary = choose (minBound, maxBound)
264− shrink = shrinker
265−
266−instance Arbitrary Word32 where
267− arbitrary = choose (minBound, maxBound)
268− shrink = shrinker
269−
270−instance Arbitrary Word64 where
271− arbitrary = choose (minBound, maxBound)
272− shrink = shrinker
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
358+ arbitrary = W <$> arbitrary
359+ shrink = map W <$> shrink . unW
360+
361+instance Arbitrary (W Word8) where
362+ arbitrary = W <$> choose (minBound, maxBound)
363+ shrink = map W . shrinker . unW
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
273461
274−integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
275−integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,
276− fromIntegral b :: Integer) g of
277− (x,g) -> (fromIntegral x, g)
462+prop_program :: Program -> Property
463+prop_program program = property $
464+ let p = mapM_ putPrimitive program
465+ g = verifyProgram (8 * fromIntegral (L.length lbs)) program
466+ lbs = runPut (runBitPut p)
467+ r = runGet (runBitGet g) lbs
468+ in r
469+
470+putPrimitive :: Primitive -> BitPut ()
471+putPrimitive p =
472+ case p of
473+ Bool b -> putBool b
474+ W8 n x -> putWord8 n x
475+ W16 n x -> putWord16 n x
476+ W32 n x -> putWord32 n x
477+ W64 n x -> putWord64 n x
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
278528
529+{-
279530instance Random Word where
280531 randomR = integralRandomR
281532 random = randomR (minBound,maxBound)
@@ -295,3 +546,4 @@ instance Random Word32 where
295546instance Random Word64 where
296547 randomR = integralRandomR
297548 random = randomR (minBound,maxBound)
549+-}
Data/Binary/Bits.hsnew file+45
@@ -0,0 +1,45 @@
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.hsnew file+22
@@ -0,0 +1,22 @@
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.hsnew file+47
@@ -0,0 +1,47 @@
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.hsnew file+496
@@ -0,0 +1,496 @@
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.hsnew file+176
@@ -0,0 +1,176 @@
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.hsnew file+285
@@ -0,0 +1,285 @@
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)2010, Lennart Kolmodin
1+Copyright (c) Lennart Kolmodin
22
33All rights reserved.
44
55Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
6+modification, are permitted provided that the following conditions
7+are met:
78
8− * Redistributions of source code must retain the above copyright
9− notice, this list of conditions and the following disclaimer.
9+1. Redistributions of source code must retain the above copyright
10+ notice, this list of conditions and the following disclaimer.
1011
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
12+2. Redistributions in binary form must reproduce the above copyright
13+ notice, this list of conditions and the following disclaimer in the
14+ documentation and/or other materials provided with the distribution.
1515
16− * Neither the name of Lennart Kolmodin nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
16+3. Neither the name of the author nor the names of his contributors
17+ may be used to endorse or promote products derived from this software
18+ without specific prior written permission.
1919
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
20+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
21+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
22+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
23+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
24+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
26+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
27+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
28+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
29+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
30+POSSIBILITY OF SUCH DAMAGE.
binary-bits.cabal+31−21
@@ -1,38 +1,48 @@
1−-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
1+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/
22name: binary-bits
3−version: 0.1
4−synopsis: Bit parsing on top of binary.
5−description: Bit parsing on top of binary. Provides functions to
6− read parts of 8/16/32/64 words.
3+version: 0.6
4+synopsis: Bit parsing/writing on top of binary.
5+description: Bit parsing/writing on top of binary. Provides functions to
6+ read and write bits to and from 8\/16\/32\/64 words.
77license: BSD3
88license-file: LICENSE
9−author: Lennart Kolmodin <kolmodin@gentoo.org>
10−maintainer: Lennart Kolmodin <kolmodin@gentoo.org>
11−-- copyright:
12−category: Data
9+author: Lennart Kolmodin <kolmodin@gmail.com>
10+maintainer: Lennart Kolmodin <kolmodin@gmail.com>
11+category: Data, Parsing
1312build-type: Simple
14−-- Extra files to be distributed with the package, such as examples or
15−-- a README.
16−-- extra-source-files:
1713
18−-- Constraint on the version of Cabal needed to build this package.
19−cabal-version: >=1.8
14+cabal-version: >=1.10
2015
16+source-repository head
17+ type: git
18+ location: git://github.com/kolmodin/binary-bits.git
2119
2220library
23− exposed-modules: BitsGet, BitsPut, Bits
21+ build-depends: base==4.*, binary >= 0.6.0.0, bytestring
2422
25− build-depends: base==4.*, binary, bytestring
26− -- other-modules:
27− -- build-tools:
23+ other-extensions: RankNTypes, MagicHash, BangPatterns, CPP
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
31+
32+ default-language: Haskell98
33+
34+ ghc-options: -O2 -Wall
2835
2936test-suite qc
3037 type: exitcode-stdio-1.0
3138 main-is: BitsQC.hs
39+ default-language: Haskell98
40+ --ghc-options: -O2 -Wall
3241
33− build-depends: binary-bits, binary,
34− base==4.*, haskell98, bytestring,
42+ build-depends: base==4.*, binary >= 0.6.0.0, bytestring,
3543 QuickCheck>=2, random,
3644 test-framework,
3745 test-framework-quickcheck2
38− ghc-options: -fhpc
46+
47+ other-extensions: RankNTypes, MagicHash, BangPatterns, CPP,
48+ FlexibleInstances, FlexibleContexts, TupleSections
flake.locknew file+59
@@ -0,0 +1,59 @@
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.nixnew file+24
@@ -0,0 +1,24 @@
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.yamlnew file+66
@@ -0,0 +1,66 @@
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.locknew file+12
@@ -0,0 +1,12 @@
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