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     , Unknown(..)
  13     )
  14     where
  15 import Control.Monad
  16 import Data.Binary
  17 import Data.Binary.Get
  18 import Data.Binary.Put
  19 import Data.Bits
  20 import qualified Data.ByteString.Lazy as L
  21 import Data.Typeable
  22 import Prelude.Unicode
  23
  24 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
  25     metaID   ∷ α → Word8
  26     metaSize ∷ α → Word32
  27
  28     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
  29
  30 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
  31
  32 instance Binary SubBlock where
  33     put (SubBlock a)
  34         = let size     = metaSize a
  35               oddBit   = if odd size   then 0x40 else 0
  36               largeBit = if size > 255 then 0x80 else 0
  37               idWord   = metaID a .|. oddBit .|. largeBit
  38           in
  39             do putWord8 idWord
  40                if size > 255 then
  41                    -- Don't forget about the endianness.
  42                    do putWord8 $ fromIntegral $ (size `shiftR`  1) .&. 0xFF
  43                       putWord8 $ fromIntegral $ (size `shiftR`  9) .&. 0xFF
  44                       putWord8 $ fromIntegral $ (size `shiftR` 17) .&. 0xFF
  45                  else
  46                       putWord8 $ fromIntegral $ (size `shiftR`  1) .&. 0xFF
  47                put a
  48                when (odd size) $ putWord8 0
  49
  50     get = do idWord ← getWord8
  51              let isOdd   = idWord .&. 0x40 ≢ 0
  52                  isLarge = idWord .&. 0x80 ≢ 0
  53                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
  54                  adj     = if isOdd then -1 else 0
  55              size ← if isLarge then
  56                          do sz0 ← getWord8
  57                             sz1 ← getWord8
  58                             sz2 ← getWord8
  59                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
  60                                        (fromIntegral sz1 `shiftL`  9) .|.
  61                                        (fromIntegral sz0 `shiftL`  1)
  62                                      ) + adj
  63                      else
  64                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
  65              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
  66              return $ runGet (getSubBlock rawID) subb
  67         where
  68           getSubBlock ∷ Word8 → Get SubBlock
  69           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy)
  70           getSubBlock unknownID
  71               = if unknownID .&. 0x20 ≡ 0 then
  72                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
  73                 else
  74                     -- It's unknown but optional. We can safely ignore it.
  75                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
  76
  77 instance Eq SubBlock where
  78     (SubBlock a) == (SubBlock b)
  79         = Just a ≡ cast b
  80
  81 instance Show SubBlock where
  82     show (SubBlock a) = show a
  83
  84 -- | Dummy metadata to pad WavPack blocks.
  85 data Dummy
  86     = Dummy {
  87         dumSize ∷ !Word32
  88       }
  89     deriving (Eq, Show, Typeable)
  90
  91 instance Metadata Dummy where
  92     metaID _ = 0x00
  93     metaSize = dumSize
  94
  95 instance Binary Dummy where
  96     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
  97     get = fmap (Dummy ∘ fromIntegral) remaining
  98
  99 -- | Unknown but optional metadata found in the WavPack block.
 100 data Unknown
 101     = Unknown {
 102         unkID   ∷ !Word8
 103       , unkData ∷ L.ByteString
 104       }
 105     deriving (Eq, Show, Typeable)
 106
 107 instance Metadata Unknown where
 108     metaID   = unkID
 109     metaSize = fromIntegral ∘ L.length ∘ unkData
 110
 111 instance Binary Unknown where
 112     put = putLazyByteString ∘ unkData
 113     get = (⊥)