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     , RIFFHeader(..)
  13     , RIFFTrailer(..)
  14     , Unknown(..)
  15     )
  16     where
  17 import Control.Monad
  18 import Data.Binary
  19 import Data.Binary.Get
  20 import Data.Binary.Put
  21 import Data.Bits
  22 import qualified Data.ByteString.Lazy as L
  23 import Data.Typeable
  24 import Prelude.Unicode
  25
  26 -- | Type class for every metadata sub-blocks.
  27 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
  28     -- | Get the metadata ID without odd-size bit nor large-block bit
  29     -- (mandatory).
  30     metaID   ∷ α → Word8
  31     -- | Get the size of metadata, excluding the metadata header
  32     -- (optional).
  33     metaSize ∷ α → Word32
  34     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
  35     -- | Cast a 'SubBlock' to this type of metadata (optional).
  36     fromSubBlock ∷ SubBlock → Maybe α
  37     fromSubBlock (SubBlock a) = cast a
  38     -- | Wrap the metadata into 'SubBlock' (optional).
  39     toSubBlock ∷ α → SubBlock
  40     toSubBlock = SubBlock
  41
  42 -- | An opaque sub-block container.
  43 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
  44                 deriving Typeable
  45
  46 instance Metadata SubBlock where
  47     metaID   (SubBlock a) = metaID a
  48     metaSize (SubBlock a) = metaSize a
  49     fromSubBlock = Just
  50     toSubBlock   = id
  51
  52 instance Binary SubBlock where
  53     put (SubBlock a)
  54         = let size     = metaSize a
  55               size'    = size + 1
  56               oddBit   = if odd size     then 0x40 else 0
  57               largeBit = if size > 0x1FE then 0x80 else 0
  58               idWord   = metaID a .|. oddBit .|. largeBit
  59           in
  60             do putWord8 idWord
  61                if size > 0x1FE then
  62                    -- Don't forget about the endianness.
  63                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
  64                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
  65                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
  66                  else
  67                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
  68                put a
  69                when (odd size) $ putWord8 0
  70
  71     get = do idWord ← getWord8
  72              let isOdd   = idWord .&. 0x40 ≢ 0
  73                  isLarge = idWord .&. 0x80 ≢ 0
  74                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
  75                  adj     = if isOdd then -1 else 0
  76              size ← if isLarge then
  77                          do sz0 ← getWord8
  78                             sz1 ← getWord8
  79                             sz2 ← getWord8
  80                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
  81                                        (fromIntegral sz1 `shiftL`  9) .|.
  82                                        (fromIntegral sz0 `shiftL`  1)
  83                                      ) + adj
  84                      else
  85                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
  86              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
  87              return $ runGet (getSubBlock rawID) subb
  88         where
  89           getSubBlock ∷ Word8 → Get SubBlock
  90           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy)
  91           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader)
  92           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer)
  93           getSubBlock unknownID
  94               = if unknownID .&. 0x20 ≡ 0 then
  95                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
  96                 else
  97                     -- It's unknown but optional. We can safely ignore it.
  98                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
  99
 100 instance Eq SubBlock where
 101     (SubBlock a) == (SubBlock b)
 102         = Just a ≡ cast b
 103
 104 instance Show SubBlock where
 105     show (SubBlock a) = show a
 106
 107 -- | Dummy metadata to pad WavPack blocks.
 108 data Dummy
 109     = Dummy {
 110         -- | Must be less than 2^25 bytes long due to the limitation
 111         -- of WavPack specification.
 112         dumSize ∷ Word32
 113       }
 114     deriving (Eq, Show, Typeable)
 115
 116 instance Metadata Dummy where
 117     metaID _ = 0x00
 118     metaSize = dumSize
 119
 120 instance Binary Dummy where
 121     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
 122     get = fmap (Dummy ∘ fromIntegral) remaining
 123
 124 -- | RIFF header for .wav files (before audio)
 125 data RIFFHeader
 126     = RIFFHeader {
 127         riffHeader ∷ L.ByteString
 128       }
 129     deriving (Eq, Show, Typeable)
 130
 131 instance Metadata RIFFHeader where
 132     metaID _ = 0x21
 133
 134 instance Binary RIFFHeader where
 135     put = putLazyByteString ∘ riffHeader
 136     get = fmap RIFFHeader getRemainingLazyByteString
 137
 138 -- | RIFF trailer for .wav files (after audio)
 139 data RIFFTrailer
 140     = RIFFTrailer {
 141         riffTrailer ∷ L.ByteString
 142       }
 143     deriving (Eq, Show, Typeable)
 144
 145 instance Metadata RIFFTrailer where
 146     metaID _ = 0x22
 147
 148 instance Binary RIFFTrailer where
 149     put = putLazyByteString ∘ riffTrailer
 150     get = fmap RIFFTrailer getRemainingLazyByteString
 151
 152 -- | Unknown but optional metadata found in the WavPack block.
 153 data Unknown
 154     = Unknown {
 155         -- | The ID of this unknown metadata without odd-size bit nor
 156         -- large-block bit.
 157         unkID   ∷ Word8
 158         -- | Raw data; must be less than 2^25 bytes long.
 159       , unkData ∷ L.ByteString
 160       }
 161     deriving (Eq, Show, Typeable)
 162
 163 instance Metadata Unknown where
 164     metaID   = unkID
 165
 166 instance Binary Unknown where
 167     put = putLazyByteString ∘ unkData
 168     get = (⊥)