@@ -2,6 +2,7 @@
22-- |
33-- Module : Data.Binary.Bits.Put
44-- Copyright : (c) Lennart Kolmodin 2010-2011
5+-- (c) Sylvain Henry 2015
56-- License : BSD3-style (see LICENSE)
67--
78-- Maintainer : kolmodin@gmail.com
@@ -56,61 +57,64 @@ putBool :: Bool -> BitPut ()
5657putBool b = putWord8 1 (if b then 0xff else 0x00)
5758
5859
60+-- | Generic putWord
61+putWord :: (Num a, FastBits a, Integral a) => Int -> a -> BitPut ()
62+putWord n w = BitPut $ \s -> PairS () (putWordS n w s)
63+
64+putWordS :: (Num a, FastBits a, Integral a) => Int -> a -> S -> S
65+putWordS n w s@(S builder b o bo) = s'
66+ where
67+ -- number of bits that will be stored in the current byte
68+ cn = min (8-o) n
69+
70+ -- new state
71+ s' = case n of
72+ 0 -> s
73+ _ -> putWordS (n-cn) w' (flush (S builder b' (o+cn) bo))
74+
75+ -- new current byte
76+ b' = shl (selectBits w) .|. b
77+
78+ -- Word containing the remaining (n-cn) bits to store in its LSB
79+ w' = case bo of
80+ BB -> w
81+ BL -> w
82+ LB -> w `fastShiftR` cn
83+ LL -> w `fastShiftR` cn
84+
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)
92+ LB -> mask cn x
93+ LL -> reverseBits cn $ mask cn x
94+
95+ -- shift left at the correct position
96+ shl :: Word8 -> Word8
97+ shl x = case bo of
98+ BB -> x `fastShiftL` (8-o-cn)
99+ BL -> x `fastShiftL` (8-o-cn)
100+ LB -> x `fastShiftL` o
101+ LL -> x `fastShiftL` o
102+
59103-- | Put the @n@ lower bits of a 'Word8'.
60104putWord8 :: Int -> Word8 -> BitPut ()
61−putWord8 n w = BitPut $ \s -> PairS () $
62− let w' = make_mask n .&. w in
63− case s of
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 $
70− let o' = o + n - 8
71− b' = t .|. (w' `shiftR` o')
72− t' = w `shiftL` (8 - o')
73− in S (b `mappend` B.singleton b') t' o' bo
105+putWord8 = putWord
74106
75107-- | Put the @n@ lower bits of a 'Word16'.
76108putWord16be :: Int -> Word16 -> BitPut ()
77−putWord16be n w
78− | n <= 8 = putWord8 n (fromIntegral w)
79− | otherwise =
80− BitPut $ \s -> PairS () $
81− let w' = make_mask n .&. w in
82− case s of
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 $
87− let o' = o + n - 8
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)
91− -- 3 bytes required
92− | otherwise -> flush $
93− let o' = o + n - 16
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)
109+putWord16be = putWord
98110
99111-- | Put the @n@ lower bits of a 'Word32'.
100112putWord32be :: Int -> Word32 -> BitPut ()
101−putWord32be n w
102− | n <= 16 = putWord16be n (fromIntegral w)
103− | otherwise = do
104− putWord32be (n-16) (w`shiftR`16)
105− putWord32be 16 (w .&. 0x0000ffff)
113+putWord32be = putWord
106114
107115-- | Put the @n@ lower bits of a 'Word64'.
108116putWord64be :: Int -> Word64 -> BitPut ()
109−putWord64be n w
110− | n <= 32 = putWord32be n (fromIntegral w)
111− | otherwise = do
112− putWord64be (n-32) (w`shiftR`32)
113− putWord64be 32 (w .&. 0xffffffff)
117+putWord64be = putWord
114118
115119-- | Put a 'ByteString'.
116120putByteString :: ByteString -> BitPut ()