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     , Unknown(..)
  19     )
  20     where
  21 import Codec.Audio.WavPack.Internal
  22 import Control.Monad
  23 import Data.Binary
  24 import Data.Binary.Get
  25 import Data.Binary.Put
  26 import Data.Bits
  27 import qualified Data.ByteString.Lazy as L
  28 import Data.Int
  29 import qualified Data.Strict as S
  30 import Data.Typeable
  31 import qualified Data.Vector.Unboxed as UV
  32 import Prelude.Unicode
  33
  34 -- | Type class for every metadata sub-blocks.
  35 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
  36     -- | Get the metadata ID without odd-size bit nor large-block bit
  37     -- (mandatory).
  38     metaID   ∷ α → Word8
  39     -- | Get the size of metadata, excluding the metadata header
  40     -- (optional).
  41     metaSize ∷ α → Word32
  42     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
  43     -- | Cast a 'SubBlock' to this type of metadata (optional).
  44     fromSubBlock ∷ SubBlock → Maybe α
  45     fromSubBlock (SubBlock a) = cast a
  46     -- | Wrap the metadata into 'SubBlock' (optional).
  47     toSubBlock ∷ α → SubBlock
  48     toSubBlock = SubBlock
  49
  50 -- | An opaque sub-block container.
  51 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
  52                 deriving Typeable
  53
  54 instance Metadata SubBlock where
  55     metaID   (SubBlock a) = metaID a
  56     metaSize (SubBlock a) = metaSize a
  57     fromSubBlock = Just
  58     toSubBlock   = id
  59
  60 instance Binary SubBlock where
  61     put (SubBlock a)
  62         = let size     = metaSize a
  63               size'    = size + 1
  64               oddBit   = if odd size     then 0x40 else 0
  65               largeBit = if size > 0x1FE then 0x80 else 0
  66               idWord   = metaID a .|. oddBit .|. largeBit
  67           in
  68             do putWord8 idWord
  69                if size > 0x1FE then
  70                    -- Don't forget about the endianness.
  71                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
  72                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
  73                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
  74                  else
  75                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
  76                put a
  77                when (odd size) $ putWord8 0
  78
  79     get = do idWord ← getWord8
  80              let isOdd   = idWord .&. 0x40 ≢ 0
  81                  isLarge = idWord .&. 0x80 ≢ 0
  82                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
  83                  adj     = if isOdd then -1 else 0
  84              size ← if isLarge then
  85                          do sz0 ← getWord8
  86                             sz1 ← getWord8
  87                             sz2 ← getWord8
  88                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
  89                                        (fromIntegral sz1 `shiftL`  9) .|.
  90                                        (fromIntegral sz0 `shiftL`  1)
  91                                      ) + adj
  92                      else
  93                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
  94              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
  95              return $ runGet (getSubBlock rawID) subb
  96         where
  97           getSubBlock ∷ Word8 → Get SubBlock
  98           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy        )
  99           getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms  )
 100           getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
 101           getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
 102           getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars  )
 103           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader   )
 104           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer  )
 105           getSubBlock unknownID
 106               = if unknownID .&. 0x20 ≡ 0 then
 107                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
 108                 else
 109                     -- It's unknown but optional. We can safely ignore it.
 110                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
 111
 112 instance Eq SubBlock where
 113     (SubBlock a) == (SubBlock b)
 114         = Just a ≡ cast b
 115
 116 instance Show SubBlock where
 117     show (SubBlock a) = show a
 118
 119 -- | Dummy metadata to pad WavPack blocks.
 120 data Dummy
 121     = Dummy {
 122         -- | Must be less than 2^25 bytes long due to the limitation
 123         -- of WavPack specification.
 124         dumSize ∷ Word32
 125       }
 126     deriving (Eq, Show, Typeable)
 127
 128 instance Metadata Dummy where
 129     metaID _ = 0x00
 130     metaSize = dumSize
 131
 132 instance Binary Dummy where
 133     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
 134     get = fmap (Dummy ∘ fromIntegral) remaining
 135
 136 -- | Decorrelation terms and deltas.
 137 data DecorrTerms
 138     = DecorrTerms {
 139         -- | @[ (term, delta) ]@
 140         dectVec ∷ !(UV.Vector (Int8, Int8))
 141       }
 142     deriving (Eq, Show, Typeable)
 143
 144 instance Metadata DecorrTerms where
 145     metaID _ = 0x02
 146     metaSize = fromIntegral ∘ UV.length ∘ dectVec
 147
 148 instance Binary DecorrTerms where
 149     put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
 150         where
 151           packDT ∷ (Int8, Int8) → Word8
 152           packDT (term, δ)
 153               = fromIntegral ( (term + 5 .&. 0x1F)
 154                                .|.
 155                                ((δ `shiftL` 5) .&. 0xE0)
 156                              )
 157     get = do n   ← remaining
 158              vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
 159              -- THINKME: unpack.c(read_decorr_terms) reverses the
 160              -- order only when they are decoding. I don't know why so
 161              -- I leave it unreversed for now.
 162              return $ DecorrTerms vec
 163         where
 164           unpackDT ∷ Word8 → (Int8, Int8)
 165           unpackDT w
 166               = let term = (fromIntegral $ w .&. 0x1F) - 5
 167                     δ    = fromIntegral $ (w `shiftR` 5) .&. 0x07
 168                 in
 169                   (term, δ)
 170
 171 -- | Decorrelation weights.
 172 data DecorrWeights
 173     = DecorrWeights {
 174       -- | For mono blocks, this is a weight vector for the single
 175       --   channel. For stereo blocks, it's interleaved as A, B, A, B,
 176       --   ...
 177         decwVec ∷ !(UV.Vector Int16)
 178       }
 179     deriving (Eq, Show, Typeable)
 180
 181 instance Metadata DecorrWeights where
 182     metaID _ = 0x03
 183     metaSize = fromIntegral ∘ UV.length ∘ decwVec
 184
 185 instance Binary DecorrWeights where
 186     put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
 187     get = do n   ← remaining
 188              vec ← UV.replicateM (fromIntegral n)
 189                     $ fmap unpackWeight getWord8
 190              -- THINKME: the same caution as DecorrTerms, but never
 191              -- try to simply reverse the vector. Think about the
 192              -- interleaving.
 193              return $ DecorrWeights vec
 194
 195 -- | Decorrelation samples
 196 data DecorrSamples
 197     = DecorrSamples {
 198       -- | The decorrelation sample vector stored in the metadata
 199       --   as-is. Actual interpretation of the vector depends on the
 200       --   number of channels and each corresponding decorrelation
 201       --   terms.
 202         decsVec ∷ !(UV.Vector Int32)
 203       }
 204     deriving (Eq, Show, Typeable)
 205
 206 instance Metadata DecorrSamples where
 207     metaID _ = 0x04
 208     metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
 209
 210 instance Binary DecorrSamples where
 211     put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
 212     get = do n   ← remaining
 213              vec ← UV.replicateM (fromIntegral $ n `div` 2)
 214                     $ fmap (exp2s ∘ fromIntegral) getWord16le
 215              return $ DecorrSamples vec
 216
 217 -- | Median log2 values.
 218 data EntropyVars
 219     = EntropyVars {
 220       -- | Median log2 values for channel A, which always exists.
 221         entVarA ∷ !(Word32, Word32, Word32)
 222       -- | Median log2 values for channel B, which is absent when it's
 223       --   mono.
 224       , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
 225       }
 226     deriving (Eq, Show, Typeable)
 227
 228 instance Metadata EntropyVars where
 229     metaID _ = 0x05
 230     metaSize ev
 231         | S.isNothing $ entVarB ev =  6
 232         | otherwise                = 12
 233
 234 instance Binary EntropyVars where
 235     put ev
 236         = do putMedians $ entVarA ev
 237              case entVarB ev of
 238                S.Nothing    → return ()
 239                S.Just medsB → putMedians medsB
 240         where
 241           -- THINKME: words.c(write_entropy_vars) is a destructive
 242           -- subroutine. It calls read_entropy_vars() to read the
 243           -- values back to compensate for the loss through the log
 244           -- function.
 245           putMedians ∷ (Word32, Word32, Word32) → Put
 246           putMedians (med0, med1, med2)
 247               = do putWord16le $ log2 med0
 248                    putWord16le $ log2 med1
 249                    putWord16le $ log2 med2
 250
 251     get = do medsA ← getMedians
 252              medsB ← do isMono ← isEmpty
 253                         if isMono then
 254                             return S.Nothing
 255                           else
 256                             fmap S.Just getMedians
 257              return $! EntropyVars medsA medsB
 258         where
 259           getMedians ∷ Get (Word32, Word32, Word32)
 260           getMedians
 261               = do med0 ← fmap exp2 getWord16le
 262                    med1 ← fmap exp2 getWord16le
 263                    med2 ← fmap exp2 getWord16le
 264                    return (med0, med1, med2)
 265
 266 -- | RIFF header for .wav files (before audio)
 267 data RIFFHeader
 268     = RIFFHeader {
 269         riffHeader ∷ L.ByteString
 270       }
 271     deriving (Eq, Show, Typeable)
 272
 273 instance Metadata RIFFHeader where
 274     metaID _ = 0x21
 275
 276 instance Binary RIFFHeader where
 277     put = putLazyByteString ∘ riffHeader
 278     get = fmap RIFFHeader getRemainingLazyByteString
 279
 280 -- | RIFF trailer for .wav files (after audio)
 281 data RIFFTrailer
 282     = RIFFTrailer {
 283         riffTrailer ∷ L.ByteString
 284       }
 285     deriving (Eq, Show, Typeable)
 286
 287 instance Metadata RIFFTrailer where
 288     metaID _ = 0x22
 289
 290 instance Binary RIFFTrailer where
 291     put = putLazyByteString ∘ riffTrailer
 292     get = fmap RIFFTrailer getRemainingLazyByteString
 293
 294 -- | Unknown but optional metadata found in the WavPack block.
 295 data Unknown
 296     = Unknown {
 297         -- | The ID of this unknown metadata without odd-size bit nor
 298         -- large-block bit.
 299         unkID   ∷ Word8
 300         -- | Raw data; must be less than 2^25 bytes long.
 301       , unkData ∷ L.ByteString
 302       }
 303     deriving (Eq, Show, Typeable)
 304
 305 instance Metadata Unknown where
 306     metaID   = unkID
 307
 308 instance Binary Unknown where
 309     put = putLazyByteString ∘ unkData
 310     get = error "unsupported operation"