3 , ExistentialQuantification
6 -- | WavPack metadata sub-blocks
7 module Codec.Audio.WavPack.Metadata
23 import Codec.Audio.WavPack.Internal
26 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
27 import Data.Binary.Get
28 import Data.Binary.Put
29 import Data.Binary.Strict.BitGet (getBit, runBitGet)
30 import qualified Data.Binary.Strict.BitGet as BG
32 import qualified Data.ByteString as S
33 import qualified Data.ByteString.Lazy as L
35 import qualified Data.Strict as S
37 import qualified Data.Vector.Unboxed as UV
38 import Prelude.Unicode
40 -- | Type class for every metadata sub-blocks.
41 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
42 -- | Get the metadata ID without odd-size bit nor large-block bit
45 -- | Get the size of metadata, excluding the metadata header
48 metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
49 -- | Cast a 'SubBlock' to this type of metadata (optional).
50 fromSubBlock ∷ SubBlock → Maybe α
51 fromSubBlock (SubBlock a) = cast a
52 -- | Wrap the metadata into 'SubBlock' (optional).
53 toSubBlock ∷ α → SubBlock
56 -- | An opaque sub-block container.
57 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
60 instance Metadata SubBlock where
61 metaID (SubBlock a) = metaID a
62 metaSize (SubBlock a) = metaSize a
66 instance Binary SubBlock where
68 = let size = metaSize a
70 oddBit = if odd size then 0x40 else 0
71 largeBit = if size > 0x1FE then 0x80 else 0
72 idWord = metaID a .|. oddBit .|. largeBit
76 -- Don't forget about the endianness.
77 do putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF
78 putWord8 $ fromIntegral $ (size' `shiftR` 9) .&. 0xFF
79 putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
81 putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF
83 when (odd size) $ putWord8 0
85 get = do idWord ← getWord8
86 let isOdd = idWord .&. 0x40 ≢ 0
87 isLarge = idWord .&. 0x80 ≢ 0
88 rawID = idWord .&. (complement 0x40) .&. (complement 0x80)
89 adj = if isOdd then -1 else 0
90 size ← if isLarge then
94 return $ ( (fromIntegral sz2 `shiftL` 17) .|.
95 (fromIntegral sz1 `shiftL` 9) .|.
96 (fromIntegral sz0 `shiftL` 1)
99 fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
100 subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
101 return $ runGet (getSubBlock rawID) subb
103 getSubBlock ∷ Word8 → Get SubBlock
104 getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy )
105 getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms )
106 getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
107 getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
108 getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars )
109 getSubBlock 0x0A = fmap SubBlock (get ∷ Get WVBitstream )
110 getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader )
111 getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer )
112 getSubBlock 0x25 = fmap SubBlock (get ∷ Get ConfigInfo )
113 getSubBlock unknownID
114 = if unknownID .&. 0x20 ≡ 0 then
115 fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
117 -- It's unknown but optional. We can safely ignore it.
118 fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
120 instance Eq SubBlock where
121 (SubBlock a) == (SubBlock b)
124 instance Show SubBlock where
125 show (SubBlock a) = show a
127 -- | Dummy metadata to pad WavPack blocks.
130 -- | Must be less than 2^25 bytes long due to the limitation
131 -- of WavPack specification.
134 deriving (Eq, Show, Typeable)
136 instance Metadata Dummy where
140 instance Binary Dummy where
141 put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
142 get = fmap (Dummy ∘ fromIntegral) remaining
144 -- | Decorrelation terms and deltas.
147 -- | @[ (term, delta) ]@
148 dectVec ∷ !(UV.Vector (Int8, Int8))
150 deriving (Eq, Show, Typeable)
152 instance Metadata DecorrTerms where
154 metaSize = fromIntegral ∘ UV.length ∘ dectVec
156 instance Binary DecorrTerms where
157 put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
159 packDT ∷ (Int8, Int8) → Word8
161 = fromIntegral ( (term + 5 .&. 0x1F)
163 ((δ `shiftL` 5) .&. 0xE0)
165 get = do n ← remaining
166 vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
167 -- THINKME: unpack.c(read_decorr_terms) reverses the
168 -- order only when they are decoding. I don't know why so
169 -- I leave it unreversed for now.
170 return $ DecorrTerms vec
172 unpackDT ∷ Word8 → (Int8, Int8)
174 = let term = (fromIntegral $ w .&. 0x1F) - 5
175 δ = fromIntegral $ (w `shiftR` 5) .&. 0x07
179 -- | Decorrelation weights.
182 -- | For mono blocks, this is a weight vector for the single
183 -- channel. For stereo blocks, it's interleaved as A, B, A, B,
185 decwVec ∷ !(UV.Vector Int16)
187 deriving (Eq, Show, Typeable)
189 instance Metadata DecorrWeights where
191 metaSize = fromIntegral ∘ UV.length ∘ decwVec
193 instance Binary DecorrWeights where
194 put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
195 get = do n ← remaining
196 vec ← UV.replicateM (fromIntegral n)
197 $ fmap unpackWeight getWord8
198 -- THINKME: the same caution as DecorrTerms, but never
199 -- try to simply reverse the vector. Think about the
201 return $ DecorrWeights vec
203 -- | Decorrelation samples
206 -- | The decorrelation sample vector stored in the metadata
207 -- as-is. Actual interpretation of the vector depends on the
208 -- number of channels and each corresponding decorrelation
210 decsVec ∷ !(UV.Vector Int32)
212 deriving (Eq, Show, Typeable)
214 instance Metadata DecorrSamples where
216 metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
218 instance Binary DecorrSamples where
219 put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
220 get = do n ← remaining
221 vec ← UV.replicateM (fromIntegral $ n `div` 2)
222 $ fmap (exp2s ∘ fromIntegral) getWord16le
223 return $ DecorrSamples vec
225 -- | Median log2 values.
228 -- | Median log2 values for channel A, which always exists.
229 entVarA ∷ !(Word32, Word32, Word32)
230 -- | Median log2 values for channel B, which is absent when it's
232 , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
234 deriving (Eq, Show, Typeable)
236 instance Metadata EntropyVars where
239 | S.isNothing $ entVarB ev = 6
242 instance Binary EntropyVars where
244 = do putMedians $ entVarA ev
246 S.Nothing → return ()
247 S.Just medsB → putMedians medsB
249 -- THINKME: words.c(write_entropy_vars) is a destructive
250 -- subroutine. It calls read_entropy_vars() to read the
251 -- values back to compensate for the loss through the log
253 putMedians ∷ (Word32, Word32, Word32) → Put
254 putMedians (med0, med1, med2)
255 = do putWord16le $ log2 med0
256 putWord16le $ log2 med1
257 putWord16le $ log2 med2
259 get = do medsA ← getMedians
260 medsB ← do isMono ← isEmpty
264 fmap S.Just getMedians
265 return $! EntropyVars medsA medsB
267 getMedians ∷ Get (Word32, Word32, Word32)
269 = do med0 ← fmap exp2 getWord16le
270 med1 ← fmap exp2 getWord16le
271 med2 ← fmap exp2 getWord16le
272 return (med0, med1, med2)
277 wvStream ∷ !L.ByteString
279 deriving (Eq, Show, Typeable)
281 instance Metadata WVBitstream where
283 metaSize = fromIntegral ∘ L.length ∘ wvStream
285 instance Binary WVBitstream where
286 put = putLazyByteString ∘ wvStream
287 get = fmap WVBitstream getRemainingLazyByteString
289 -- | RIFF header for .wav files (before audio)
292 riffHeader ∷ !L.ByteString
294 deriving (Eq, Show, Typeable)
296 instance Metadata RIFFHeader where
298 metaSize = fromIntegral ∘ L.length ∘ riffHeader
300 instance Binary RIFFHeader where
301 put = putLazyByteString ∘ riffHeader
302 get = fmap RIFFHeader getRemainingLazyByteString
304 -- | RIFF trailer for .wav files (after audio)
307 riffTrailer ∷ !L.ByteString
309 deriving (Eq, Show, Typeable)
311 instance Metadata RIFFTrailer where
313 metaSize = fromIntegral ∘ L.length ∘ riffTrailer
315 instance Binary RIFFTrailer where
316 put = putLazyByteString ∘ riffTrailer
317 get = fmap RIFFTrailer getRemainingLazyByteString
319 -- | Configuration information.
324 -- | high quality mode
327 , cfgVeryHigh ∷ !Bool
328 -- | bitrate is kbps, not bits / sample
329 , cfgBitrateKbps ∷ !Bool
330 -- | automatic noise shaping
331 , cfgAutoShaping ∷ !Bool
332 -- | shaping mode specified
333 , cfgShapeOverride ∷ !Bool
334 -- | joint-stereo mode specified
335 , cfgJointOverride ∷ !Bool
336 -- | dynamic noise shaping
337 , cfgDynamicShaping ∷ !Bool
338 -- | create executable
339 , cfgCreateEXE ∷ !Bool
340 -- | create correction file
341 , cfgCreateWVC ∷ !Bool
342 -- | maximize hybrid compression
343 , cfgOptimizeWVC ∷ !Bool
344 -- | calc noise in hybrid mode
345 , cfgCalcNoise ∷ !Bool
346 -- | obsolete (for information)
347 , cfgLossyMode ∷ !Bool
348 -- | extra processing mode level (1-6)
349 , cfgExtraModeLevel ∷ !(S.Maybe Word8)
350 -- | no wvx stream w/ floats & big ints
352 -- | compute & store MD5 signature
353 , cfgMD5Checksum ∷ !Bool
354 -- | merge blocks of equal redundancy
355 , cfgMergeBlocks ∷ !Bool
356 -- | optimize for mono streams posing
357 , cfgOptimizeMono ∷ !Bool
359 deriving (Eq, Show, Typeable)
361 instance Metadata ConfigInfo where
364 | S.isJust $ cfgExtraModeLevel ci
369 instance Binary ConfigInfo where
371 = let !bs = runBitPut $
372 do putBit $ cfgOptimizeMono ci
373 putNBits 2 (0 ∷ Word8) -- unused
374 putBit $ cfgMergeBlocks ci
375 putBit $ cfgMD5Checksum ci
376 putBit $ cfgSkipWVX ci
377 putBit $ S.isJust $ cfgExtraModeLevel ci
378 putBit $ cfgLossyMode ci
379 putBit $ cfgCalcNoise ci
380 putNBits 2 (0 ∷ Word8) -- unused
381 putBit $ cfgOptimizeWVC ci
382 putBit $ cfgCreateWVC ci
383 putBit $ cfgCreateEXE ci
384 putBit $ cfgDynamicShaping ci
385 putBit $ cfgJointOverride ci
386 putBit $ cfgShapeOverride ci
387 putBit $ cfgAutoShaping ci
388 putBit $ cfgBitrateKbps ci
389 putBit $ cfgVeryHigh ci
391 putBit False -- unused
393 putBit False -- unused
395 do putLazyByteString (L.reverse bs)
396 case cfgExtraModeLevel ci of
397 S.Nothing → return ()
398 S.Just eml → putWord8 eml
400 get = do bs ← getBytes 3
401 eml ← do xmode ← fmap (¬) isEmpty
406 let r = runBitGet (S.reverse bs) $
407 do optimizeMono ← getBit
419 dynamicShaping ← getBit
420 jointOverride ← getBit
421 shapeOverride ← getBit
432 , cfgVeryHigh = veryHigh
433 , cfgBitrateKbps = bitrateKbps
434 , cfgAutoShaping = autoShaping
435 , cfgShapeOverride = shapeOverride
436 , cfgJointOverride = jointOverride
437 , cfgDynamicShaping = dynamicShaping
438 , cfgCreateEXE = createEXE
439 , cfgCreateWVC = createWVC
440 , cfgOptimizeWVC = optimizeWVC
441 , cfgCalcNoise = calcNoise
442 , cfgLossyMode = lossyMode
443 , cfgExtraModeLevel = if extraMode then
447 , cfgSkipWVX = skipWVX
448 , cfgMD5Checksum = md5Checksum
449 , cfgMergeBlocks = mergeBlocks
450 , cfgOptimizeMono = optimizeMono
457 -- | Unknown but optional metadata found in the WavPack block.
460 -- | The ID of this unknown metadata without odd-size bit nor
463 -- | Raw data; must be less than 2^25 bytes long.
464 , unkData ∷ L.ByteString
466 deriving (Eq, Show, Typeable)
468 instance Metadata Unknown where
471 instance Binary Unknown where
472 put = putLazyByteString ∘ unkData
473 get = error "unsupported operation"