6 -- | Lazy bitstrings based on 'L.ByteString' which treats a byte
7 -- stream as a bit sequence in the same way as WavPack's manner.
8 module Codec.Audio.WavPack.BitString
9 ( -- * The BitString Type
26 -- * Conversion from/to 'L.ByteString'
36 import qualified Data.ByteString.Lazy as L
39 import qualified Data.Strict as S
41 import Prelude hiding (drop, head, length, null, splitAt, tail, take)
42 import Prelude.Unicode
44 -- | The BitString Type.
48 , leftBytes ∷ !L.ByteString
50 , rightBytes ∷ !L.ByteString
55 instance Eq BitString where
56 a == b = leftRem a' ≡ leftRem b' ∧
57 leftBytes a' ≡ leftBytes b' ∧
58 rightRem a' ≡ rightRem b'
63 normalise ∷ BitString → BitString
65 | remLen (leftRem bs) ≡ 8
68 , leftBytes = L.cons (remByte $ leftRem bs) $ leftBytes bs
70 | remLen (rightRem bs) ≡ 8
72 rightBytes = L.cons (remByte $ rightRem bs) $ rightBytes bs
77 leftBytes = leftBytes bs `L.append` (L.reverse $ rightBytes bs)
78 , rightBytes = L.empty
83 -- | bit length from 0 to 8
85 -- | current byte @(0 <= remByte <= (1 `'shiftL'` 'remLen') - 1)@
91 remEmpty = Remnant 0 0
93 remNull ∷ Remnant → Bool
94 remNull = (0 ≡) ∘ remLen
96 remSingleton ∷ Bool -> Remnant
97 remSingleton b = Remnant {
99 , remByte = if b then 1 else 0
102 byteToRem ∷ Word8 → Remnant
103 byteToRem w = Remnant {
108 remToStr ∷ Remnant → L.ByteString
110 | remNull r = L.empty
111 | otherwise = L.singleton $ remByte r
113 consRem ∷ Bool → Remnant → (# Remnant, S.Maybe Word8 #)
115 | remLen r ≡ 8 = (# remSingleton b, S.Just $ remByte r #)
116 | remLen r ≡ 7 = (# remEmpty, S.Just w' #)
117 | otherwise = let !r' = r {
118 remLen = remLen r + 1
124 w' = (remByte r `shiftL` 1)
128 snocRem ∷ Remnant → Bool → (# S.Maybe Word8, Remnant #)
130 | remLen r ≡ 8 = (# S.Just $ remByte r, remSingleton b #)
131 | remLen r ≡ 7 = (# S.Just w', remEmpty #)
132 | otherwise = let !r' = r {
133 remLen = remLen r + 1
139 w' | b = bit (remLen r) .|. remByte r
140 | otherwise = remByte r
142 unconsRem ∷ Remnant → (# S.Maybe Bool, Remnant #)
144 | remNull r = (# S.Nothing, remEmpty #)
145 | otherwise = let !b = remByte r `testBit` 0
147 remLen = remLen r - 1
148 , remByte = remByte r `shiftR` 1
153 unconsBytes ∷ L.ByteString → (# S.Maybe Remnant, L.ByteString #)
155 = case L.uncons bs of
157 → (# S.Just (byteToRem w), bs' #)
159 → (# S.Nothing, L.empty #)
161 appendRem ∷ Remnant → Remnant → Remnant
162 appendRem a b = Remnant {
163 remLen = remLen a + remLen b
164 , remByte = (remByte a `shiftL` remLen b) .|. remByte b
167 splitRemAt ∷ Integral n ⇒ n → Remnant → (# S.Maybe Remnant, Remnant #)
169 | remLen r ≥ fromIntegral n
171 remLen = fromIntegral n
172 , remByte = remByte r .&. ((1 `shiftL` fromIntegral n) - 1)
175 remLen = remLen r - fromIntegral n
176 , remByte = remByte r `shiftR` fromIntegral n
181 = (# S.Nothing, remEmpty #)
183 -- | /O(1)/ The same as 'empty'.
187 -- | /O(1)/ The empty 'BitString'.
191 , leftBytes = L.empty
192 , rightBytes = L.empty
193 , rightRem = remEmpty
196 -- | /O(1)/ Convert a 'Bool' into a 'BitString'.
197 singleton ∷ Bool → BitString
198 singleton b = BitString {
199 leftRem = remSingleton b
200 , leftBytes = L.empty
201 , rightBytes = L.empty
202 , rightRem = remEmpty
205 -- | /O(1)/ Prepend a bit to the beginning of a 'BitString'.
206 cons ∷ Bool → BitString → BitString
208 = case consRem b $ leftRem bs of
212 , leftBytes = L.cons' w $ leftBytes bs
216 → bs { leftRem = lr' }
218 -- | /O(1)/ Append a bit to the end of a 'BitString'.
219 snoc ∷ BitString → Bool → BitString
221 = case snocRem (rightRem bs) b of
224 rightBytes = L.cons' w $ rightBytes bs
229 → bs { rightRem = rr' }
231 -- | /amortized O(1)/ Extract the first bit of a 'BitString', which
232 -- must be non-empty.
233 head ∷ BitString → Bool
234 head bs = case uncons bs of
238 → error "head: empty BitString"
240 -- | /amortized O(1)/ Extract the bits after the head of a
241 -- 'BitString', which must be non-empty.
242 tail ∷ BitString → BitString
243 tail bs = case uncons bs of
247 → error "tail: empty BitString"
249 -- | /amortized O(1)/ Extract the the head and tail of a 'BitString',
250 -- returning 'Nothing' if it's empty.
251 uncons ∷ BitString → Maybe (Bool, BitString)
253 = case unconsRem $ leftRem bs of
255 → Just (b, bs { leftRem = lr' })
258 → case unconsBytes $ leftBytes bs of
260 → let !bs' = bs { leftRem = lr
267 → if L.null $ rightBytes bs then
268 case unconsRem $ rightRem bs of
270 → Just (b, bs { rightRem = rr' })
275 let !bs' = bs { leftBytes = L.reverse
281 -- | /O(1)/ Test whether a 'BitString' is empty.
282 null ∷ BitString → Bool
284 = remNull (leftRem bs)
286 L.null (leftBytes bs)
288 L.null (rightBytes bs)
290 remNull (rightRem bs)
292 -- | /O(n)/ Return the number of bits in a 'BitString'.
293 length ∷ Integral n ⇒ BitString → n
295 = fromIntegral $ ( fromIntegral (remLen $ leftRem bs)
297 L.length (leftBytes bs) ⋅ 8
299 L.length (rightBytes bs) ⋅ 8
301 fromIntegral (remLen $ rightRem bs)
303 {-# SPECIALISE length ∷ BitString → Int64 #-}
305 -- | /O(1)/ Convert a 'L.ByteString' into a 'BitString'.
306 fromByteString ∷ L.ByteString → BitString
307 fromByteString bs = BitString {
310 , rightBytes = L.empty
311 , rightRem = remEmpty
314 -- | /O(n)/ Convert a 'BitString' into 'L.ByteString', padding
315 -- incomplete bytes to single bytes with necessary 0's at their
316 -- MSB. Thus the following equation does not hold when the length of
317 -- 'BitString' isn't multiple of 8.
319 -- > fromByteString . toByteString = id
321 -- But the following always holds true.
323 -- > toByteString . fromByteString = id
324 toByteString ∷ BitString → L.ByteString
326 = L.concat [ remToStr $ leftRem bs
328 , L.reverse $ rightBytes bs
329 , remToStr $ rightRem bs
332 -- | /O(n)/ @'take' n bs@ returns the prefix of @bs@ of length
333 -- @n@. @bs@ must have at least @n@ bits.
334 take ∷ Integral n ⇒ n → BitString → BitString
335 take n xs = case splitAt n xs of
338 -- | /O(n)/ @'drop' n bs@ returns the suffix of @bs@ after the first
339 -- @n@ bits. @bs@ must have at least @n@ bits.
340 drop ∷ Integral n ⇒ n → BitString → BitString
341 drop n xs = case splitAt n xs of
342 (_, dropped) → dropped
344 -- | /O(n)/ @'splitAt' n bs@ is equivalent to @('take' n bs, 'drop' n
346 splitAt ∷ Integral n ⇒ n → BitString → (BitString, BitString)
348 = case splitRemAt n $ leftRem bs of
350 -- The leftRem has enough bits.
351 → let !h' = BitString {
353 , leftBytes = L.empty
354 , rightBytes = L.empty
355 , rightRem = remEmpty
358 (h', bs { leftRem = lr' })
361 → let !bytesToTake = (n - fromIntegral (remLen $ leftRem bs)) `div` 8
362 !amortised = leftBytes bs `L.append` (L.reverse $ rightBytes bs)
363 -- 0 ≤ bitsToTake < 8 - remLen (leftRem bs)
364 -- ∴ remLen (leftRem bs) + bitsToTake < 8
365 !bitsToTake = n - bytesToTake ⋅ 8 - fromIntegral (remLen $ leftRem bs)
367 case (# bytesToTake, L.uncons amortised #) of
368 (#_, Just (!w, amor') #)
369 -- There is at least one byte in the byte pool
371 → let !h1 = leftRem bs
373 = case splitRemAt bitsToTake $ byteToRem w of
374 (# S.Just h2', lr'' #) → (# h2', lr'' #)
375 (# S.Nothing , _ #) → error "internal error"
376 !h = h1 `appendRem` h2
378 = L.splitAt (fromIntegral bytesToTake) amor'
380 if L.length bytes ≡ fromIntegral bytesToTake then
381 -- The byte pool actuall has at least
382 -- bytesToTake bytes.
383 let !h' = BitString {
386 , rightBytes = L.empty
387 , rightRem = remEmpty
392 , rightBytes = L.empty
393 , rightRem = rightRem bs
398 error "splitAt: not enough bits"
401 -- No bytes are in the byte pool but the
402 -- rightRem may have enough bits.
403 → case splitRemAt bitsToTake $ rightRem bs of
405 → let !h' = BitString {
407 , leftBytes = L.empty
408 , rightBytes = L.empty
413 , leftBytes = L.empty
414 , rightBytes = L.empty
421 → error "splitAt: not enough bits"
424 -- No bytes are in the byte pool but more than 8
425 -- bits are requested. The rightRem can't have
427 → error "splitAt: not enough bits"