Codec/Audio/WavPack/BitString.hs

   1 {-# LANGUAGE
   2     UnboxedTuples
   3   , UnicodeSyntax
   4   #-}
   5 -- | Lazy bitstrings based on 'L.ByteString' which treats a byte
   6 -- stream as a bit sequence in the same way as WavPack's manner.
   7 module Codec.Audio.WavPack.BitString
   8     ( -- * The BitString Type
   9       BitString
  10
  11       -- * Construction
  12     , (∅)
  13     , singleton
  14
  15       -- * Basic Interface
  16     , cons
  17     , snoc
  18     , head
  19     , uncons
  20     , tail
  21     , null
  22     , length
  23
  24       -- * Conversion from/to 'L.ByteString'
  25     , fromByteString
  26     , toByteString
  27     )
  28     where
  29 import qualified Data.ByteString.Lazy as L
  30 import Data.Bits
  31 import Data.Int
  32 import qualified Data.Strict as S
  33 import Data.Word
  34 import Prelude hiding (head, length, null, tail)
  35 import Prelude.Unicode
  36
  37 -- | The BitString Type.
  38 data BitString
  39     = BitString {
  40         leftRem    ∷ !Remnant
  41       , leftBytes  ∷ !L.ByteString
  42       -- | reversed
  43       , rightBytes ∷ !L.ByteString
  44       , rightRem   ∷ !Remnant
  45       }
  46     deriving (Eq, Show)
  47
  48 data Remnant
  49     = Remnant {
  50       -- | bit length from 0 to 8
  51         remLen  ∷ !Int
  52       -- | current byte
  53       , remByte ∷ !Word8
  54       }
  55     deriving (Eq, Show)
  56
  57 remEmpty ∷ Remnant
  58 remEmpty = Remnant 0 0
  59
  60 remNull ∷ Remnant → Bool
  61 remNull = (0 ≡) ∘ remLen
  62
  63 remSingleton ∷ Bool -> Remnant
  64 remSingleton b = Remnant {
  65                    remLen  = 1
  66                  , remByte = if b then 1 else 0
  67                  }
  68
  69 byteToRem ∷ Word8 → Remnant
  70 byteToRem w = Remnant {
  71                 remLen  = 8
  72               , remByte = w
  73               }
  74
  75 remToStr ∷ Remnant → L.ByteString
  76 remToStr r
  77     | remNull r = L.empty
  78     | otherwise = L.singleton $ remByte r
  79
  80 consRem ∷ Bool → Remnant → (# Remnant, S.Maybe Word8 #)
  81 consRem b r
  82     | remLen r ≡ 8 = (# remSingleton b, S.Just $ remByte r #)
  83     | remLen r ≡ 7 = (# remEmpty, S.Just w' #)
  84     | otherwise     = let !r' = r {
  85                                   remLen  = remLen r + 1
  86                                 , remByte = w'
  87                                 }
  88                       in
  89                         (# r', S.Nothing #)
  90     where
  91       w' = (remByte r `shiftR` 1)
  92            .|.
  93            if b then 1 else 0
  94
  95 snocRem ∷ Remnant → Bool → (# S.Maybe Word8, Remnant #)
  96 snocRem r b
  97     | remLen r ≡ 8 = (# S.Just $ remByte r, remSingleton b #)
  98     | remLen r ≡ 7 = (# S.Just w', remEmpty #)
  99     | otherwise     = let !r' = r {
 100                                   remLen  = remLen r + 1
 101                                 , remByte = w'
 102                                 }
 103                       in
 104                         (# S.Nothing, r' #)
 105     where
 106       w' | b         = bit (remLen r) .|. remByte r
 107          | otherwise = remByte r
 108
 109 unconsRem ∷ Remnant → (# S.Maybe Bool, Remnant #)
 110 unconsRem r
 111     | remNull r = (# S.Nothing, remEmpty #)
 112     | otherwise = let !b  = remByte r `testBit` 1
 113                       !r' = Remnant {
 114                               remLen  = remLen r - 1
 115                             , remByte = remByte r `shiftR` 1
 116                             }
 117                   in
 118                     (# S.Just b, r' #)
 119
 120 unconsBytes ∷ L.ByteString → (# S.Maybe Remnant, L.ByteString #)
 121 unconsBytes bs
 122     = case L.uncons bs of
 123         Just (w, bs')
 124             → (# S.Just (byteToRem w), bs' #)
 125         Nothing
 126             → (# S.Nothing, L.empty #)
 127
 128 -- | /O(1)/ The empty 'BitString'.
 129 (∅) ∷ BitString
 130 (∅) = BitString {
 131         leftRem    = remEmpty
 132       , leftBytes  = L.empty
 133       , rightBytes = L.empty
 134       , rightRem   = remEmpty
 135       }
 136
 137 -- | /O(1)/ Convert a 'Bool' into a 'BitString'.
 138 singleton ∷ Bool → BitString
 139 singleton b = BitString {
 140                 leftRem    = remSingleton b
 141               , leftBytes  = L.empty
 142               , rightBytes = L.empty
 143               , rightRem   = remEmpty
 144               }
 145
 146 -- | /O(1)/ Prepend a bit to the beginning of a 'BitString'.
 147 cons ∷ Bool → BitString → BitString
 148 cons b bs
 149     = case consRem b $ leftRem bs of
 150         (# lr', S.Just w #)
 151             → bs {
 152                  leftRem   = lr'
 153                , leftBytes = L.cons' w $ leftBytes bs
 154                }
 155
 156         (# lr', S.Nothing #)
 157             → bs { leftRem = lr' }
 158
 159 -- | /O(1)/ Append a bit to the end of a 'BitString'.
 160 snoc ∷ BitString → Bool → BitString
 161 snoc bs b
 162     = case snocRem (rightRem bs) b of
 163         (# S.Just w, rr' #)
 164             → bs {
 165                  rightBytes = L.cons' w $ rightBytes bs
 166                , rightRem   = rr'
 167                }
 168
 169         (# S.Nothing, rr' #)
 170             → bs { rightRem = rr' }
 171
 172 -- | /amortized O(1)/ Extract the first bit of a 'BitString', which
 173 -- must be non-empty.
 174 head ∷ BitString → Bool
 175 head bs = case uncons bs of
 176             Just (b, _ )
 177                 → b
 178             Nothing
 179                 → error "head: empty BitString"
 180
 181 -- | /amortized O(1)/ Extract the bits after the head of a
 182 -- 'BitString', which must be non-empty.
 183 tail ∷ BitString → BitString
 184 tail bs = case uncons bs of
 185             Just (_, bs')
 186                 → bs'
 187             Nothing
 188                 → error "tail: empty BitString"
 189
 190 -- | /amortized O(1)/ Extract the the head and tail of a 'BitString',
 191 -- returning 'Nothing' if it's empty.
 192 uncons ∷ BitString → Maybe (Bool, BitString)
 193 uncons bs
 194     = case unconsRem $ leftRem bs of
 195         (# S.Just b, lr' #)
 196             → Just (b, bs { leftRem = lr' })
 197
 198         (# S.Nothing, _ #)
 199             → case unconsBytes $ leftBytes bs of
 200                  (# S.Just lr, lb' #)
 201                      → let !bs' = bs { leftRem   = lr
 202                                       , leftBytes = lb'
 203                                       }
 204                         in
 205                           uncons bs'
 206
 207                  (# S.Nothing, _ #)
 208                      → if L.null $ rightBytes bs then
 209                             case unconsRem $ rightRem bs of
 210                               (# S.Just b, rr' #)
 211                                   → Just (b, bs { rightRem = rr' })
 212
 213                               (# S.Nothing, _ #)
 214                                   → Nothing
 215                         else
 216                             let !bs' = bs { leftBytes = L.reverse
 217                                                         $ rightBytes bs
 218                                           }
 219                             in
 220                               uncons bs'
 221
 222 -- | /O(1)/ Test whether a 'BitString' is empty.
 223 null ∷ BitString → Bool
 224 null bs
 225     = remLen (leftRem bs) ≡ 0
 226       ∧
 227       L.null (leftBytes bs)
 228       ∧
 229       L.null (rightBytes bs)
 230       ∧
 231       remLen (rightRem bs) ≡ 0
 232
 233 -- | /O(n)/ Return the number of bits in a 'BitString'.
 234 length ∷ Integral n ⇒ BitString → n
 235 length bs
 236     = fromIntegral $ ( fromIntegral (remLen $ leftRem bs)
 237                        +
 238                        L.length (leftBytes bs) ⋅ 8
 239                        +
 240                        L.length (rightBytes bs) ⋅ 8
 241                        +
 242                        fromIntegral (remLen $ rightRem bs)
 243                      )
 244 {-# SPECIALISE length ∷ BitString → Int64 #-}
 245
 246 -- | /O(1)/ Convert a 'L.ByteString' into a 'BitString'.
 247 fromByteString ∷ L.ByteString → BitString
 248 fromByteString bs = BitString {
 249                       leftRem    = remEmpty
 250                     , leftBytes  = bs
 251                     , rightBytes = L.empty
 252                     , rightRem   = remEmpty
 253                     }
 254
 255 -- | /O(n)/ Convert a 'BitString' into 'L.ByteString', padding
 256 -- incomplete bytes to single bytes with necessary 0's at their
 257 -- MSB. Thus the following equation does not hold when the length of
 258 -- 'BitString' isn't multiple of 8.
 259 --
 260 -- > fromByteString . toByteString = id
 261 --
 262 -- But the following always holds true.
 263 --
 264 -- > toByteString . fromByteString = id
 265 toByteString ∷ BitString → L.ByteString
 266 toByteString bs
 267     = L.concat [ remToStr $ leftRem bs
 268                , leftBytes bs
 269                , L.reverse $ rightBytes bs
 270                , remToStr $ rightRem bs
 271                ]