{-# 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 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where metaID ∷ α → Word8 metaSize ∷ α → Word32 metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put data SubBlock = ∀α. Metadata α ⇒ SubBlock α 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 { 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 { unkID ∷ !Word8 , 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 = (⊥)