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