@@ -39,7 +39,8 @@ import Data.Binary.Put ( Put )
3939import Data.Binary.Bits.Internal
4040import Data.Binary.Bits.BitOrder
4141
42−import Data.ByteString
42+import Data.ByteString as BS
43+import Data.ByteString.Unsafe as BS
4344
4445import Control.Applicative
4546import Data.Bits
@@ -100,6 +101,11 @@ putWordS n w s@(S builder b o bo) = s'
100101 LB -> x `fastShiftL` o
101102 LL -> x `fastShiftL` o
102103
104+ flush s2@(S b2 w2 o2 bo2)
105+ | o2 == 8 = S (b2 `mappend` B.singleton w2) 0 0 bo2
106+ | otherwise = s2
107+
108+
103109-- | Put the @n@ lower bits of a 'Word8'.
104110putWord8 :: Int -> Word8 -> BitPut ()
105111putWord8 = putWord
@@ -117,29 +123,42 @@ putWord64be :: Int -> Word64 -> BitPut ()
117123putWord64be = putWord
118124
119125-- | Put a 'ByteString'.
126+--
127+-- Examples: 3 bits are already written in the current byte
128+-- BB: ABCDEFGH IJKLMNOP -> xxxABCDE FGHIJKLM NOPxxxxx
129+-- LB: ABCDEFGH IJKLMNOP -> LMNOPxxx DEFGHIJK xxxxxABC
130+-- BL: ABCDEFGH IJKLMNOP -> xxxPONML KJIHGFED CBAxxxxx
131+-- LL: ABCDEFGH IJKLMNOP -> EDCBAxxx MLKJIHGF xxxxxPON
120132putByteString :: ByteString -> BitPut ()
121−putByteString bs = do
122− offset <- hasOffset
123− if offset
124− then mapM_ (putWord8 8) (unpack bs) -- naive
125− else joinPut (Put.putByteString bs)
126− where
127− hasOffset = BitPut $ \ s@(S _ _ o _) -> PairS (o /= 0) s
133+putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
134+
135+putByteStringS :: ByteString -> S -> S
136+putByteStringS bs (S builder b 0 BB) = S (builder `mappend` B.fromByteString bs) b 0 BB
137+putByteStringS bs s@(S _ _ _ BB)
138+ | BS.null bs = s
139+ | otherwise = putByteStringS (BS.unsafeTail bs) (putWordS 8 (BS.unsafeHead bs) s)
140+putByteStringS bs (S builder b o bo) = putByteStringS bs' (S builder b o BB)
141+ where
142+ rev = BS.map (reverseBits 8)
143+
144+ bs' = case bo of
145+ BL -> BS.reverse (rev bs)
146+ LB -> BS.reverse bs
147+ LL -> rev bs
148+ BB -> bs -- should not occur, already matched but the compiler doesn't detect it
149+
150+
128151
129152-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
130153-- before 'Put' executes to ensure byte alignment.
154+--
155+-- Warning: this method does not take bit order into account (i.e. BB assumed)
131156joinPut :: Put -> BitPut ()
132157joinPut m = BitPut $ \s0 -> PairS () $
133158 let (S b0 _ _ bo) = flushIncomplete s0
134159 b = Put.execPut m
135160 in (S (b0`mappend`b) 0 0 bo)
136161
137−flush :: S -> S
138−flush s@(S b w o bo)
139− | o > 8 = error "flush: offset > 8"
140− | o == 8 = S (b `mappend` B.singleton w) 0 0 bo
141− | otherwise = s
142−
143162flushIncomplete :: S -> S
144163flushIncomplete s@(S b w o bo)
145164 | o == 0 = s