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