{-# LANGUAGE DeriveDataTypeable , ExistentialQuantification , UnicodeSyntax #-} -- | WavPack metadata sub-blocks module Codec.Audio.WavPack.Metadata ( Metadata(..) , SubBlock , Dummy(..) , Unknown(..) ) where import Control.Monad import Data.Binary import Data.Binary.Get import Data.Binary.Put import Data.Bits import qualified Data.ByteString.Lazy as L import Data.Typeable import Prelude.Unicode -- | Type class for every metadata sub-blocks. class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where -- | Get the metadata ID (mandatory). metaID ∷ α → Word8 -- | Get the size of metadata (optional). metaSize ∷ α → Word32 metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put -- | Cast a 'SubBlock' to this type of metadata (optional). fromSubBlock ∷ SubBlock → Maybe α fromSubBlock (SubBlock a) = cast a -- | Wrap the metadata into 'SubBlock' (optional). toSubBlock ∷ α → SubBlock toSubBlock = SubBlock -- | An opaque sub-block container. data SubBlock = ∀α. Metadata α ⇒ SubBlock α deriving Typeable instance Metadata SubBlock where metaID (SubBlock a) = metaID a metaSize (SubBlock a) = metaSize a fromSubBlock = Just toSubBlock = id instance Binary SubBlock where put (SubBlock a) = let size = metaSize a oddBit = if odd size then 0x40 else 0 largeBit = if size > 255 then 0x80 else 0 idWord = metaID a .|. oddBit .|. largeBit in do putWord8 idWord if size > 255 then -- Don't forget about the endianness. do putWord8 $ fromIntegral $ (size `shiftR` 1) .&. 0xFF putWord8 $ fromIntegral $ (size `shiftR` 9) .&. 0xFF putWord8 $ fromIntegral $ (size `shiftR` 17) .&. 0xFF else putWord8 $ fromIntegral $ (size `shiftR` 1) .&. 0xFF put a when (odd size) $ putWord8 0 get = do idWord ← getWord8 let isOdd = idWord .&. 0x40 ≢ 0 isLarge = idWord .&. 0x80 ≢ 0 rawID = idWord .&. (complement 0x40) .&. (complement 0x80) adj = if isOdd then -1 else 0 size ← if isLarge then do sz0 ← getWord8 sz1 ← getWord8 sz2 ← getWord8 return $ ( (fromIntegral sz2 `shiftL` 17) .|. (fromIntegral sz1 `shiftL` 9) .|. (fromIntegral sz0 `shiftL` 1) ) + adj else fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8 subb ← getLazyByteString $ fromIntegral (size ∷ Word32) return $ runGet (getSubBlock rawID) subb where getSubBlock ∷ Word8 → Get SubBlock getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy) getSubBlock unknownID = if unknownID .&. 0x20 ≡ 0 then fail ("Unknown WavPack metadata ID: " ⧺ show unknownID) else -- It's unknown but optional. We can safely ignore it. fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString instance Eq SubBlock where (SubBlock a) == (SubBlock b) = Just a ≡ cast b instance Show SubBlock where show (SubBlock a) = show a -- | Dummy metadata to pad WavPack blocks. data Dummy = Dummy { -- | Must be less than 2^25 bytes long due to the limitation -- of WavPack specification. dumSize ∷ Word32 } deriving (Eq, Show, Typeable) instance Metadata Dummy where metaID _ = 0x00 metaSize = dumSize instance Binary Dummy where put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize get = fmap (Dummy ∘ fromIntegral) remaining -- | Unknown but optional metadata found in the WavPack block. data Unknown = Unknown { -- | The ID of this unknown metadata. unkID ∷ Word8 -- | Raw data; must be less than 2^25 bytes long. , unkData ∷ L.ByteString } deriving (Eq, Show, Typeable) instance Metadata Unknown where metaID = unkID metaSize = fromIntegral ∘ L.length ∘ unkData instance Binary Unknown where put = putLazyByteString ∘ unkData get = (⊥)