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