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