3 , ExistentialQuantification
6 -- | WavPack metadata sub-blocks
7 module Codec.Audio.WavPack.Metadata
21 import Codec.Audio.WavPack.Internal
24 import Data.Binary.Get
25 import Data.Binary.Put
27 import qualified Data.ByteString.Lazy as L
29 import qualified Data.Strict as S
31 import qualified Data.Vector.Unboxed as UV
32 import Prelude.Unicode
34 -- | Type class for every metadata sub-blocks.
35 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
36 -- | Get the metadata ID without odd-size bit nor large-block bit
39 -- | Get the size of metadata, excluding the metadata header
42 metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
43 -- | Cast a 'SubBlock' to this type of metadata (optional).
44 fromSubBlock ∷ SubBlock → Maybe α
45 fromSubBlock (SubBlock a) = cast a
46 -- | Wrap the metadata into 'SubBlock' (optional).
47 toSubBlock ∷ α → SubBlock
50 -- | An opaque sub-block container.
51 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
54 instance Metadata SubBlock where
55 metaID (SubBlock a) = metaID a
56 metaSize (SubBlock a) = metaSize a
60 instance Binary SubBlock where
62 = let size = metaSize a
64 oddBit = if odd size then 0x40 else 0
65 largeBit = if size > 0x1FE then 0x80 else 0
66 idWord = metaID a .|. oddBit .|. largeBit
70 -- Don't forget about the endianness.
71 do putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF
72 putWord8 $ fromIntegral $ (size' `shiftR` 9) .&. 0xFF
73 putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
75 putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF
77 when (odd size) $ putWord8 0
79 get = do idWord ← getWord8
80 let isOdd = idWord .&. 0x40 ≢ 0
81 isLarge = idWord .&. 0x80 ≢ 0
82 rawID = idWord .&. (complement 0x40) .&. (complement 0x80)
83 adj = if isOdd then -1 else 0
84 size ← if isLarge then
88 return $ ( (fromIntegral sz2 `shiftL` 17) .|.
89 (fromIntegral sz1 `shiftL` 9) .|.
90 (fromIntegral sz0 `shiftL` 1)
93 fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
94 subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
95 return $ runGet (getSubBlock rawID) subb
97 getSubBlock ∷ Word8 → Get SubBlock
98 getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy )
99 getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms )
100 getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
101 getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
102 getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars )
103 getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader )
104 getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer )
105 getSubBlock unknownID
106 = if unknownID .&. 0x20 ≡ 0 then
107 fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
109 -- It's unknown but optional. We can safely ignore it.
110 fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
112 instance Eq SubBlock where
113 (SubBlock a) == (SubBlock b)
116 instance Show SubBlock where
117 show (SubBlock a) = show a
119 -- | Dummy metadata to pad WavPack blocks.
122 -- | Must be less than 2^25 bytes long due to the limitation
123 -- of WavPack specification.
126 deriving (Eq, Show, Typeable)
128 instance Metadata Dummy where
132 instance Binary Dummy where
133 put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
134 get = fmap (Dummy ∘ fromIntegral) remaining
136 -- | Decorrelation terms and deltas.
139 -- | @[ (term, delta) ]@
140 dectVec ∷ !(UV.Vector (Int8, Int8))
142 deriving (Eq, Show, Typeable)
144 instance Metadata DecorrTerms where
146 metaSize = fromIntegral ∘ UV.length ∘ dectVec
148 instance Binary DecorrTerms where
149 put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
151 packDT ∷ (Int8, Int8) → Word8
153 = fromIntegral ( (term + 5 .&. 0x1F)
155 ((δ `shiftL` 5) .&. 0xE0)
157 get = do n ← remaining
158 vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
159 -- THINKME: unpack.c(read_decorr_terms) reverses the
160 -- order only when they are decoding. I don't know why so
161 -- I leave it unreversed for now.
162 return $ DecorrTerms vec
164 unpackDT ∷ Word8 → (Int8, Int8)
166 = let term = (fromIntegral $ w .&. 0x1F) - 5
167 δ = fromIntegral $ (w `shiftR` 5) .&. 0x07
171 -- | Decorrelation weights.
174 -- | For mono blocks, this is a weight vector for the single
175 -- channel. For stereo blocks, it's interleaved as A, B, A, B,
177 decwVec ∷ !(UV.Vector Int16)
179 deriving (Eq, Show, Typeable)
181 instance Metadata DecorrWeights where
183 metaSize = fromIntegral ∘ UV.length ∘ decwVec
185 instance Binary DecorrWeights where
186 put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
187 get = do n ← remaining
188 vec ← UV.replicateM (fromIntegral n)
189 $ fmap unpackWeight getWord8
190 -- THINKME: the same caution as DecorrTerms, but never
191 -- try to simply reverse the vector. Think about the
193 return $ DecorrWeights vec
195 -- | Decorrelation samples
198 -- | The decorrelation sample vector stored in the metadata
199 -- as-is. Actual interpretation of the vector depends on the
200 -- number of channels and each corresponding decorrelation
202 decsVec ∷ !(UV.Vector Int32)
204 deriving (Eq, Show, Typeable)
206 instance Metadata DecorrSamples where
208 metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
210 instance Binary DecorrSamples where
211 put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
212 get = do n ← remaining
213 vec ← UV.replicateM (fromIntegral $ n `div` 2)
214 $ fmap (exp2s ∘ fromIntegral) getWord16le
215 return $ DecorrSamples vec
217 -- | Median log2 values.
220 -- | Median log2 values for channel A, which always exists.
221 entVarA ∷ !(Word32, Word32, Word32)
222 -- | Median log2 values for channel B, which is absent when it's
224 , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
226 deriving (Eq, Show, Typeable)
228 instance Metadata EntropyVars where
231 | S.isNothing $ entVarB ev = 6
234 instance Binary EntropyVars where
236 = do putMedians $ entVarA ev
238 S.Nothing → return ()
239 S.Just medsB → putMedians medsB
241 -- THINKME: words.c(write_entropy_vars) is a destructive
242 -- subroutine. It calls read_entropy_vars() to read the
243 -- values back to compensate for the loss through the log
245 putMedians ∷ (Word32, Word32, Word32) → Put
246 putMedians (med0, med1, med2)
247 = do putWord16le $ log2 med0
248 putWord16le $ log2 med1
249 putWord16le $ log2 med2
251 get = do medsA ← getMedians
252 medsB ← do isMono ← isEmpty
256 fmap S.Just getMedians
257 return $! EntropyVars medsA medsB
259 getMedians ∷ Get (Word32, Word32, Word32)
261 = do med0 ← fmap exp2 getWord16le
262 med1 ← fmap exp2 getWord16le
263 med2 ← fmap exp2 getWord16le
264 return (med0, med1, med2)
266 -- | RIFF header for .wav files (before audio)
269 riffHeader ∷ L.ByteString
271 deriving (Eq, Show, Typeable)
273 instance Metadata RIFFHeader where
276 instance Binary RIFFHeader where
277 put = putLazyByteString ∘ riffHeader
278 get = fmap RIFFHeader getRemainingLazyByteString
280 -- | RIFF trailer for .wav files (after audio)
283 riffTrailer ∷ L.ByteString
285 deriving (Eq, Show, Typeable)
287 instance Metadata RIFFTrailer where
290 instance Binary RIFFTrailer where
291 put = putLazyByteString ∘ riffTrailer
292 get = fmap RIFFTrailer getRemainingLazyByteString
294 -- | Unknown but optional metadata found in the WavPack block.
297 -- | The ID of this unknown metadata without odd-size bit nor
300 -- | Raw data; must be less than 2^25 bytes long.
301 , unkData ∷ L.ByteString
303 deriving (Eq, Show, Typeable)
305 instance Metadata Unknown where
308 instance Binary Unknown where
309 put = putLazyByteString ∘ unkData
310 get = error "unsupported operation"