git.iko.soy/binary-bits
on master help sign in
Implement putByteString
a64cb3bSylvain Henry
Data/Binary/Bits/Put.hs+33−14
compare with master
unifiedsplit
@@ -39,7 +39,8 @@ import Data.Binary.Put ( Put )
39import Data.Binary.Bits.Internal
39import Data.Binary.Bits.Internal
40import Data.Binary.Bits.BitOrder
40import Data.Binary.Bits.BitOrder
41
41
42−import Data.ByteString
42+import Data.ByteString as BS
43+import Data.ByteString.Unsafe as BS
43
44
44import Control.Applicative
45import Control.Applicative
45import Data.Bits
46import Data.Bits
@@ -100,6 +101,11 @@ putWordS n w s@(S builder b o bo) = s'
100 LB -> x `fastShiftL` o
101 LB -> x `fastShiftL` o
101 LL -> x `fastShiftL` o
102 LL -> x `fastShiftL` o
102
103
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+
103-- | Put the @n@ lower bits of a 'Word8'.
109-- | Put the @n@ lower bits of a 'Word8'.
104putWord8 :: Int -> Word8 -> BitPut ()
110putWord8 :: Int -> Word8 -> BitPut ()
105putWord8 = putWord
111putWord8 = putWord
@@ -117,29 +123,42 @@ putWord64be :: Int -> Word64 -> BitPut ()
117putWord64be = putWord
123putWord64be = putWord
118
124
119-- | Put a 'ByteString'.
125-- | 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
120putByteString :: ByteString -> BitPut ()
132putByteString :: ByteString -> BitPut ()
121−putByteString bs = do
133+putByteString bs = BitPut $ \s -> PairS () (putByteStringS bs s)
122− offset <- hasOffset
134+
123− if offset
135+putByteStringS :: ByteString -> S -> S
124− then mapM_ (putWord8 8) (unpack bs) -- naive
136+putByteStringS bs (S builder b 0 BB) = S (builder `mappend` B.fromByteString bs) b 0 BB
125− else joinPut (Put.putByteString bs)
137+putByteStringS bs s@(S _ _ _ BB)
126− where
138+ | BS.null bs = s
127− hasOffset = BitPut $ \ s@(S _ _ o _) -> PairS (o /= 0) 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+
128
151
129-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
152-- | Run a 'Put' inside 'BitPut'. Any partially written bytes will be flushed
130-- before 'Put' executes to ensure byte alignment.
153-- before 'Put' executes to ensure byte alignment.
154+--
155+-- Warning: this method does not take bit order into account (i.e. BB assumed)
131joinPut :: Put -> BitPut ()
156joinPut :: Put -> BitPut ()
132joinPut m = BitPut $ \s0 -> PairS () $
157joinPut m = BitPut $ \s0 -> PairS () $
133 let (S b0 _ _ bo) = flushIncomplete s0
158 let (S b0 _ _ bo) = flushIncomplete s0
134 b = Put.execPut m
159 b = Put.execPut m
135 in (S (b0`mappend`b) 0 0 bo)
160 in (S (b0`mappend`b) 0 0 bo)
136
161
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−
143flushIncomplete :: S -> S
162flushIncomplete :: S -> S
144flushIncomplete s@(S b w o bo)
163flushIncomplete s@(S b w o bo)
145 | o == 0 = s
164 | o == 0 = s