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