@@ -2,6 +2,7 @@
3-- Module : Data.Binary.Bits.Put
3-- Module : Data.Binary.Bits.Put
4-- Copyright : (c) Lennart Kolmodin 2010-2011
4-- Copyright : (c) Lennart Kolmodin 2010-2011
5+-- (c) Sylvain Henry 2015
5-- License : BSD3-style (see LICENSE)
6-- License : BSD3-style (see LICENSE)
7-- Maintainer : kolmodin@gmail.com
8-- Maintainer : kolmodin@gmail.com
@@ -56,61 +57,64 @@ putBool :: Bool -> BitPut ()
56putBool b = putWord8 1 (if b then 0xff else 0x00)
57putBool b = putWord8 1 (if b then 0xff else 0x00)
61+putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()
62+putWord n w = BitPut $ \s -> PairS () (putWordS n w s)
64+putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S
65+putWordS n w s@(S builder b o bo) = s'
67+ -- number of bits that will be stored in the current byte
73+ _ -> putWordS (n-cn) w' (flush (S builder b' (o+cn) bo))
76+ b' = shl (selectBits w) .|. b
78+ -- Word containing the remaining (n-cn) bits to store in its LSB
82+ LB -> w `fastShiftR` cn
83+ LL -> w `fastShiftR` cn
85+ -- Select bits to store in the current byte.
86+ -- Put them in the correct order and return them in the least-significant
87+ -- bits of the returned value
88+ selectBits :: (Num a, FastBits a, Integral a) => a -> Word8
89+ selectBits x = fromIntegral $ case bo of
90+ BB -> mask cn $ x `fastShiftR` (n-cn)
91+ BL -> reverseBits cn $ mask cn $ x `fastShiftR` (n-cn)
93+ LL -> reverseBits cn $ mask cn x
95+ -- shift left at the correct position
96+ shl :: Word8 -> Word8
98+ BB -> x `fastShiftL` (8-o-cn)
99+ BL -> x `fastShiftL` (8-o-cn)
100+ LB -> x `fastShiftL` o
101+ LL -> x `fastShiftL` o
59-- | Put the @n@ lower bits of a 'Word8'.
103-- | Put the @n@ lower bits of a 'Word8'.
60putWord8 :: Int -> Word8 -> BitPut ()
104putWord8 :: Int -> Word8 -> BitPut ()
61−putWord8 n w = BitPut $ \s -> PairS () $
105+putWord8 = putWord
62− let w' = make_mask n .&. w in
64− -- a whole word8, no offset
65− (S b t o bo) | n == 8 && o == 0 -> flush $ S b w n bo
66− -- less than a word8, will fit in the current word8
67− | n <= 8 - o -> flush $ S b (t .|. (w' `shiftL` (8 - n - o))) (o+n) bo
68− -- will finish this word8, and spill into the next one
69− | otherwise -> flush $
71− b' = t .|. (w' `shiftR` o')
72− t' = w `shiftL` (8 - o')
73− in S (b `mappend` B.singleton b') t' o' bo
75-- | Put the @n@ lower bits of a 'Word16'.
107-- | Put the @n@ lower bits of a 'Word16'.
76putWord16be :: Int -> Word16 -> BitPut ()
108putWord16be :: Int -> Word16 -> BitPut ()
77−putWord16be n w
109+putWord16be = putWord
78− | n <= 8 = putWord8 n (fromIntegral w)
80− BitPut $ \s -> PairS () $
81− let w' = make_mask n .&. w in
83− -- as n>=9, it's too big to fit into one single byte
84− -- it'll either use 2 or 3 bytes
85− -- it'll fit in 2 bytes
86− (S b t o bo) | o + n <= 16 -> flush $
88− b' = t .|. fromIntegral (w' `shiftR` o')
89− t' = fromIntegral (w `shiftL` (8-o'))
90− in (S (b `mappend` B.singleton b') t' o' bo)
92− | otherwise -> flush $
94− b' = t .|. fromIntegral (w' `shiftR` (o' + 8))
95− b'' = fromIntegral ((w `shiftR` o') .&. 0xff)
96− t' = fromIntegral (w `shiftL` (8-o'))
97− in (S (b `mappend` B.singleton b' `mappend` B.singleton b'') t' o' bo)
99-- | Put the @n@ lower bits of a 'Word32'.
111-- | Put the @n@ lower bits of a 'Word32'.
100putWord32be :: Int -> Word32 -> BitPut ()
112putWord32be :: Int -> Word32 -> BitPut ()
101−putWord32be n w
113+putWord32be = putWord
102− | n <= 16 = putWord16be n (fromIntegral w)
104− putWord32be (n-16) (w`shiftR`16)
105− putWord32be 16 (w .&. 0x0000ffff)
107-- | Put the @n@ lower bits of a 'Word64'.
115-- | Put the @n@ lower bits of a 'Word64'.
108putWord64be :: Int -> Word64 -> BitPut ()
116putWord64be :: Int -> Word64 -> BitPut ()
109−putWord64be n w
117+putWord64be = putWord
110− | n <= 32 = putWord32be n (fromIntegral w)
112− putWord64be (n-32) (w`shiftR`32)
113− putWord64be 32 (w .&. 0xffffffff)
115-- | Put a 'ByteString'.
119-- | Put a 'ByteString'.
116putByteString :: ByteString -> BitPut ()
120putByteString :: ByteString -> BitPut ()