Codec/Audio/WavPack/Metadata.hs

   1 {-# LANGUAGE
   2     DeriveDataTypeable
   3   , ExistentialQuantification
   4   , UnicodeSyntax
   5   #-}
   6 -- | WavPack metadata sub-blocks
   7 module Codec.Audio.WavPack.Metadata
   8     ( Metadata(..)
   9     , SubBlock
  10
  11     , Dummy(..)
  12     , DecorrTerms(..)
  13     , DecorrWeights(..)
  14     , DecorrSamples(..)
  15     , EntropyVars(..)
  16     , WVBitstream(..)
  17     , RIFFHeader(..)
  18     , RIFFTrailer(..)
  19     , ConfigInfo(..)
  20     , Unknown(..)
  21     )
  22     where
  23 import qualified Codec.Audio.WavPack.BitString as B
  24 import Codec.Audio.WavPack.Internal
  25 import Control.Monad
  26 import Data.Binary
  27 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
  28 import Data.Binary.Get
  29 import Data.Binary.Put
  30 import Data.Binary.Strict.BitGet (getBit, runBitGet)
  31 import qualified Data.Binary.Strict.BitGet as BG
  32 import Data.Bits
  33 import qualified Data.ByteString as S
  34 import qualified Data.ByteString.Lazy as L
  35 import Data.Int
  36 import qualified Data.Strict as S
  37 import Data.Typeable
  38 import qualified Data.Vector.Unboxed as UV
  39 import Prelude.Unicode
  40
  41 -- | Type class for every metadata sub-blocks.
  42 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
  43     -- | Get the metadata ID without odd-size bit nor large-block bit
  44     -- (mandatory).
  45     metaID   ∷ α → Word8
  46     -- | Get the size of metadata, excluding the metadata header
  47     -- (optional).
  48     metaSize ∷ α → Word32
  49     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
  50     -- | Cast a 'SubBlock' to this type of metadata (optional).
  51     fromSubBlock ∷ SubBlock → Maybe α
  52     fromSubBlock (SubBlock a) = cast a
  53     -- | Wrap the metadata into 'SubBlock' (optional).
  54     toSubBlock ∷ α → SubBlock
  55     toSubBlock = SubBlock
  56
  57 -- | An opaque sub-block container.
  58 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
  59                 deriving Typeable
  60
  61 instance Metadata SubBlock where
  62     metaID   (SubBlock a) = metaID a
  63     metaSize (SubBlock a) = metaSize a
  64     fromSubBlock = Just
  65     toSubBlock   = id
  66
  67 instance Binary SubBlock where
  68     put (SubBlock a)
  69         = let size     = metaSize a
  70               size'    = size + 1
  71               oddBit   = if odd size     then 0x40 else 0
  72               largeBit = if size > 0x1FE then 0x80 else 0
  73               idWord   = metaID a .|. oddBit .|. largeBit
  74           in
  75             do putWord8 idWord
  76                if size > 0x1FE then
  77                    -- Don't forget about the endianness.
  78                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
  79                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
  80                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
  81                  else
  82                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
  83                put a
  84                when (odd size) $ putWord8 0
  85
  86     get = do idWord ← getWord8
  87              let isOdd   = idWord .&. 0x40 ≢ 0
  88                  isLarge = idWord .&. 0x80 ≢ 0
  89                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
  90                  adj     = if isOdd then -1 else 0
  91              size ← if isLarge then
  92                          do sz0 ← getWord8
  93                             sz1 ← getWord8
  94                             sz2 ← getWord8
  95                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
  96                                        (fromIntegral sz1 `shiftL`  9) .|.
  97                                        (fromIntegral sz0 `shiftL`  1)
  98                                      ) + adj
  99                      else
 100                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
 101              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
 102              return $ runGet (getSubBlock rawID) subb
 103         where
 104           getSubBlock ∷ Word8 → Get SubBlock
 105           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy        )
 106           getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms  )
 107           getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
 108           getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
 109           getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars  )
 110           getSubBlock 0x0A = fmap SubBlock (get ∷ Get WVBitstream  )
 111           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader   )
 112           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer  )
 113           getSubBlock 0x25 = fmap SubBlock (get ∷ Get ConfigInfo   )
 114           getSubBlock unknownID
 115               = if unknownID .&. 0x20 ≡ 0 then
 116                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
 117                 else
 118                     -- It's unknown but optional. We can safely ignore it.
 119                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
 120
 121 instance Eq SubBlock where
 122     (SubBlock a) == (SubBlock b)
 123         = Just a ≡ cast b
 124
 125 instance Show SubBlock where
 126     show (SubBlock a) = show a
 127
 128 -- | Dummy metadata to pad WavPack blocks.
 129 data Dummy
 130     = Dummy {
 131         -- | Must be less than 2^25 bytes long due to the limitation
 132         -- of WavPack specification.
 133         dumSize ∷ !Word32
 134       }
 135     deriving (Eq, Show, Typeable)
 136
 137 instance Metadata Dummy where
 138     metaID _ = 0x00
 139     metaSize = dumSize
 140
 141 instance Binary Dummy where
 142     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
 143     get = fmap (Dummy ∘ fromIntegral) remaining
 144
 145 -- | Decorrelation terms and deltas.
 146 data DecorrTerms
 147     = DecorrTerms {
 148         -- | @[ (term, delta) ]@
 149         dectVec ∷ !(UV.Vector (Int8, Int8))
 150       }
 151     deriving (Eq, Show, Typeable)
 152
 153 instance Metadata DecorrTerms where
 154     metaID _ = 0x02
 155     metaSize = fromIntegral ∘ UV.length ∘ dectVec
 156
 157 instance Binary DecorrTerms where
 158     put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
 159         where
 160           packDT ∷ (Int8, Int8) → Word8
 161           packDT (term, δ)
 162               = fromIntegral ( (term + 5 .&. 0x1F)
 163                                .|.
 164                                ((δ `shiftL` 5) .&. 0xE0)
 165                              )
 166     get = do n   ← remaining
 167              vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
 168              -- THINKME: unpack.c(read_decorr_terms) reverses the
 169              -- order only when they are decoding. I don't know why so
 170              -- I leave it unreversed for now.
 171              return $ DecorrTerms vec
 172         where
 173           unpackDT ∷ Word8 → (Int8, Int8)
 174           unpackDT w
 175               = let term = (fromIntegral $ w .&. 0x1F) - 5
 176                     δ    = fromIntegral $ (w `shiftR` 5) .&. 0x07
 177                 in
 178                   (term, δ)
 179
 180 -- | Decorrelation weights.
 181 data DecorrWeights
 182     = DecorrWeights {
 183       -- | For mono blocks, this is a weight vector for the single
 184       --   channel. For stereo blocks, it's interleaved as A, B, A, B,
 185       --   ...
 186         decwVec ∷ !(UV.Vector Int16)
 187       }
 188     deriving (Eq, Show, Typeable)
 189
 190 instance Metadata DecorrWeights where
 191     metaID _ = 0x03
 192     metaSize = fromIntegral ∘ UV.length ∘ decwVec
 193
 194 instance Binary DecorrWeights where
 195     put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
 196     get = do n   ← remaining
 197              vec ← UV.replicateM (fromIntegral n)
 198                     $ fmap unpackWeight getWord8
 199              -- THINKME: the same caution as DecorrTerms, but never
 200              -- try to simply reverse the vector. Think about the
 201              -- interleaving.
 202              return $ DecorrWeights vec
 203
 204 -- | Decorrelation samples
 205 data DecorrSamples
 206     = DecorrSamples {
 207       -- | The decorrelation sample vector stored in the metadata
 208       --   as-is. Actual interpretation of the vector depends on the
 209       --   number of channels and each corresponding decorrelation
 210       --   terms.
 211         decsVec ∷ !(UV.Vector Int32)
 212       }
 213     deriving (Eq, Show, Typeable)
 214
 215 instance Metadata DecorrSamples where
 216     metaID _ = 0x04
 217     metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
 218
 219 instance Binary DecorrSamples where
 220     put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
 221     get = do n   ← remaining
 222              vec ← UV.replicateM (fromIntegral $ n `div` 2)
 223                     $ fmap (exp2s ∘ fromIntegral) getWord16le
 224              return $ DecorrSamples vec
 225
 226 -- | Median log2 values.
 227 data EntropyVars
 228     = EntropyVars {
 229       -- | Median log2 values for channel A, which always exists.
 230         entVarA ∷ !(Word32, Word32, Word32)
 231       -- | Median log2 values for channel B, which is absent when it's
 232       --   mono.
 233       , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
 234       }
 235     deriving (Eq, Show, Typeable)
 236
 237 instance Metadata EntropyVars where
 238     metaID _ = 0x05
 239     metaSize ev
 240         | S.isNothing $ entVarB ev =  6
 241         | otherwise                = 12
 242
 243 instance Binary EntropyVars where
 244     put ev
 245         = do putMedians $ entVarA ev
 246              case entVarB ev of
 247                S.Nothing    → return ()
 248                S.Just medsB → putMedians medsB
 249         where
 250           -- THINKME: words.c(write_entropy_vars) is a destructive
 251           -- subroutine. It calls read_entropy_vars() to read the
 252           -- values back to compensate for the loss through the log
 253           -- function.
 254           putMedians ∷ (Word32, Word32, Word32) → Put
 255           putMedians (med0, med1, med2)
 256               = do putWord16le $ log2 med0
 257                    putWord16le $ log2 med1
 258                    putWord16le $ log2 med2
 259
 260     get = do medsA ← getMedians
 261              medsB ← do isMono ← isEmpty
 262                         if isMono then
 263                             return S.Nothing
 264                           else
 265                             fmap S.Just getMedians
 266              return $! EntropyVars medsA medsB
 267         where
 268           getMedians ∷ Get (Word32, Word32, Word32)
 269           getMedians
 270               = do med0 ← fmap exp2 getWord16le
 271                    med1 ← fmap exp2 getWord16le
 272                    med2 ← fmap exp2 getWord16le
 273                    return (med0, med1, med2)
 274
 275 -- | WV Bitstream
 276 data WVBitstream
 277     = WVBitstream {
 278         wvStream ∷ !B.BitString
 279       }
 280     deriving (Eq, Show, Typeable)
 281
 282 instance Metadata WVBitstream where
 283     metaID _ = 0x0A
 284     metaSize = (`div` 8) ∘ B.length ∘ wvStream
 285
 286 instance Binary WVBitstream where
 287     put = putLazyByteString ∘ B.toByteString ∘ wvStream
 288     get = fmap (WVBitstream ∘ B.fromByteString) getRemainingLazyByteString
 289
 290 -- | RIFF header for .wav files (before audio)
 291 data RIFFHeader
 292     = RIFFHeader {
 293         riffHeader ∷ !L.ByteString
 294       }
 295     deriving (Eq, Show, Typeable)
 296
 297 instance Metadata RIFFHeader where
 298     metaID _ = 0x21
 299     metaSize = fromIntegral ∘ L.length ∘ riffHeader
 300
 301 instance Binary RIFFHeader where
 302     put = putLazyByteString ∘ riffHeader
 303     get = fmap RIFFHeader getRemainingLazyByteString
 304
 305 -- | RIFF trailer for .wav files (after audio)
 306 data RIFFTrailer
 307     = RIFFTrailer {
 308         riffTrailer ∷ !L.ByteString
 309       }
 310     deriving (Eq, Show, Typeable)
 311
 312 instance Metadata RIFFTrailer where
 313     metaID _ = 0x22
 314     metaSize = fromIntegral ∘ L.length ∘ riffTrailer
 315
 316 instance Binary RIFFTrailer where
 317     put = putLazyByteString ∘ riffTrailer
 318     get = fmap RIFFTrailer getRemainingLazyByteString
 319
 320 -- | Configuration information.
 321 data ConfigInfo
 322     = ConfigInfo {
 323       -- | fast mode
 324         cfgFast           ∷ !Bool
 325       -- | high quality mode
 326       , cfgHigh           ∷ !Bool
 327       -- | very high
 328       , cfgVeryHigh       ∷ !Bool
 329       -- | bitrate is kbps, not bits / sample
 330       , cfgBitrateKbps    ∷ !Bool
 331       -- | automatic noise shaping
 332       , cfgAutoShaping    ∷ !Bool
 333       -- | shaping mode specified
 334       , cfgShapeOverride  ∷ !Bool
 335       -- | joint-stereo mode specified
 336       , cfgJointOverride  ∷ !Bool
 337       -- | dynamic noise shaping
 338       , cfgDynamicShaping ∷ !Bool
 339       -- | create executable
 340       , cfgCreateEXE      ∷ !Bool
 341       -- | create correction file
 342       , cfgCreateWVC      ∷ !Bool
 343       -- | maximize hybrid compression
 344       , cfgOptimizeWVC    ∷ !Bool
 345       -- | calc noise in hybrid mode
 346       , cfgCalcNoise      ∷ !Bool
 347       -- | obsolete (for information)
 348       , cfgLossyMode      ∷ !Bool
 349       -- | extra processing mode level (1-6)
 350       , cfgExtraModeLevel ∷ !(S.Maybe Word8)
 351       -- | no wvx stream w/ floats & big ints
 352       , cfgSkipWVX        ∷ !Bool
 353       -- | compute & store MD5 signature
 354       , cfgMD5Checksum    ∷ !Bool
 355       -- | merge blocks of equal redundancy
 356       , cfgMergeBlocks    ∷ !Bool
 357       -- | optimize for mono streams posing
 358       , cfgOptimizeMono   ∷ !Bool
 359       }
 360     deriving (Eq, Show, Typeable)
 361
 362 instance Metadata ConfigInfo where
 363     metaID _ = 0x25
 364     metaSize ci
 365         | S.isJust $ cfgExtraModeLevel ci
 366             = 4
 367         | otherwise
 368             = 3
 369
 370 instance Binary ConfigInfo where
 371     put ci
 372         = let !bs = runBitPut $
 373                     do putBit $ cfgOptimizeMono   ci
 374                        putNBits 2 (0 ∷ Word8) -- unused
 375                        putBit $ cfgMergeBlocks    ci
 376                        putBit $ cfgMD5Checksum    ci
 377                        putBit $ cfgSkipWVX        ci
 378                        putBit $ S.isJust $ cfgExtraModeLevel ci
 379                        putBit $ cfgLossyMode      ci
 380                        putBit $ cfgCalcNoise      ci
 381                        putNBits 2 (0 ∷ Word8) -- unused
 382                        putBit $ cfgOptimizeWVC    ci
 383                        putBit $ cfgCreateWVC      ci
 384                        putBit $ cfgCreateEXE      ci
 385                        putBit $ cfgDynamicShaping ci
 386                        putBit $ cfgJointOverride  ci
 387                        putBit $ cfgShapeOverride  ci
 388                        putBit $ cfgAutoShaping    ci
 389                        putBit $ cfgBitrateKbps    ci
 390                        putBit $ cfgVeryHigh       ci
 391                        putBit $ cfgHigh           ci
 392                        putBit False -- unused
 393                        putBit $ cfgFast           ci
 394                        putBit False -- unused
 395           in
 396             do putLazyByteString (L.reverse bs)
 397                case cfgExtraModeLevel ci of
 398                  S.Nothing  → return ()
 399                  S.Just eml → putWord8 eml
 400
 401     get = do bs  ← getBytes 3
 402              eml ← do xmode ← fmap (¬) isEmpty
 403                       if xmode then
 404                           fmap S.Just getWord8
 405                         else
 406                           return S.Nothing
 407              let r = runBitGet (S.reverse bs) $
 408                      do optimizeMono   ← getBit
 409                         BG.skip 2 -- unused
 410                         mergeBlocks    ← getBit
 411                         md5Checksum    ← getBit
 412                         skipWVX        ← getBit
 413                         extraMode      ← getBit
 414                         lossyMode      ← getBit
 415                         calcNoise      ← getBit
 416                         BG.skip 2 -- unused
 417                         optimizeWVC    ← getBit
 418                         createWVC      ← getBit
 419                         createEXE      ← getBit
 420                         dynamicShaping ← getBit
 421                         jointOverride  ← getBit
 422                         shapeOverride  ← getBit
 423                         autoShaping    ← getBit
 424                         bitrateKbps    ← getBit
 425                         veryHigh       ← getBit
 426                         high           ← getBit
 427                         BG.skip 1 -- unused
 428                         fast           ← getBit
 429                         BG.skip 1 -- unused
 430                         return ConfigInfo {
 431                                      cfgFast           = fast
 432                                    , cfgHigh           = high
 433                                    , cfgVeryHigh       = veryHigh
 434                                    , cfgBitrateKbps    = bitrateKbps
 435                                    , cfgAutoShaping    = autoShaping
 436                                    , cfgShapeOverride  = shapeOverride
 437                                    , cfgJointOverride  = jointOverride
 438                                    , cfgDynamicShaping = dynamicShaping
 439                                    , cfgCreateEXE      = createEXE
 440                                    , cfgCreateWVC      = createWVC
 441                                    , cfgOptimizeWVC    = optimizeWVC
 442                                    , cfgCalcNoise      = calcNoise
 443                                    , cfgLossyMode      = lossyMode
 444                                    , cfgExtraModeLevel = if extraMode then
 445                                                              eml
 446                                                          else
 447                                                              S.Nothing
 448                                    , cfgSkipWVX        = skipWVX
 449                                    , cfgMD5Checksum    = md5Checksum
 450                                    , cfgMergeBlocks    = mergeBlocks
 451                                    , cfgOptimizeMono   = optimizeMono
 452                                    }
 453
 454              case r of
 455                Left err → fail err
 456                Right ci → return ci
 457
 458 -- | Unknown but optional metadata found in the WavPack block.
 459 data Unknown
 460     = Unknown {
 461         -- | The ID of this unknown metadata without odd-size bit nor
 462         -- large-block bit.
 463         unkID   ∷ Word8
 464         -- | Raw data; must be less than 2^25 bytes long.
 465       , unkData ∷ L.ByteString
 466       }
 467     deriving (Eq, Show, Typeable)
 468
 469 instance Metadata Unknown where
 470     metaID   = unkID
 471
 472 instance Binary Unknown where
 473     put = putLazyByteString ∘ unkData
 474     get = error "unsupported operation"