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