3 , ExistentialQuantification
6 -- | WavPack metadata sub-blocks
7 module Codec.Audio.WavPack.Metadata
22 import Codec.Audio.WavPack.Internal
25 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
26 import Data.Binary.Get
27 import Data.Binary.Put
28 import Data.Binary.Strict.BitGet (getBit, runBitGet)
29 import qualified Data.Binary.Strict.BitGet as BG
31 import qualified Data.ByteString as S
32 import qualified Data.ByteString.Lazy as L
34 import qualified Data.Strict as S
36 import qualified Data.Vector.Unboxed as UV
37 import Prelude.Unicode
39 -- | Type class for every metadata sub-blocks.
40 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
41 -- | Get the metadata ID without odd-size bit nor large-block bit
44 -- | Get the size of metadata, excluding the metadata header
47 metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
48 -- | Cast a 'SubBlock' to this type of metadata (optional).
49 fromSubBlock ∷ SubBlock → Maybe α
50 fromSubBlock (SubBlock a) = cast a
51 -- | Wrap the metadata into 'SubBlock' (optional).
52 toSubBlock ∷ α → SubBlock
55 -- | An opaque sub-block container.
56 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
59 instance Metadata SubBlock where
60 metaID (SubBlock a) = metaID a
61 metaSize (SubBlock a) = metaSize a
65 instance Binary SubBlock where
67 = let size = metaSize a
69 oddBit = if odd size then 0x40 else 0
70 largeBit = if size > 0x1FE then 0x80 else 0
71 idWord = metaID a .|. oddBit .|. largeBit
75 -- Don't forget about the endianness.
76 do putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF
77 putWord8 $ fromIntegral $ (size' `shiftR` 9) .&. 0xFF
78 putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
80 putWord8 $ fromIntegral $ (size' `shiftR` 1) .&. 0xFF
82 when (odd size) $ putWord8 0
84 get = do idWord ← getWord8
85 let isOdd = idWord .&. 0x40 ≢ 0
86 isLarge = idWord .&. 0x80 ≢ 0
87 rawID = idWord .&. (complement 0x40) .&. (complement 0x80)
88 adj = if isOdd then -1 else 0
89 size ← if isLarge then
93 return $ ( (fromIntegral sz2 `shiftL` 17) .|.
94 (fromIntegral sz1 `shiftL` 9) .|.
95 (fromIntegral sz0 `shiftL` 1)
98 fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
99 subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
100 return $ runGet (getSubBlock rawID) subb
102 getSubBlock ∷ Word8 → Get SubBlock
103 getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy )
104 getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms )
105 getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
106 getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
107 getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars )
108 getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader )
109 getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer )
110 getSubBlock 0x25 = fmap SubBlock (get ∷ Get ConfigInfo )
111 getSubBlock unknownID
112 = if unknownID .&. 0x20 ≡ 0 then
113 fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
115 -- It's unknown but optional. We can safely ignore it.
116 fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
118 instance Eq SubBlock where
119 (SubBlock a) == (SubBlock b)
122 instance Show SubBlock where
123 show (SubBlock a) = show a
125 -- | Dummy metadata to pad WavPack blocks.
128 -- | Must be less than 2^25 bytes long due to the limitation
129 -- of WavPack specification.
132 deriving (Eq, Show, Typeable)
134 instance Metadata Dummy where
138 instance Binary Dummy where
139 put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
140 get = fmap (Dummy ∘ fromIntegral) remaining
142 -- | Decorrelation terms and deltas.
145 -- | @[ (term, delta) ]@
146 dectVec ∷ !(UV.Vector (Int8, Int8))
148 deriving (Eq, Show, Typeable)
150 instance Metadata DecorrTerms where
152 metaSize = fromIntegral ∘ UV.length ∘ dectVec
154 instance Binary DecorrTerms where
155 put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
157 packDT ∷ (Int8, Int8) → Word8
159 = fromIntegral ( (term + 5 .&. 0x1F)
161 ((δ `shiftL` 5) .&. 0xE0)
163 get = do n ← remaining
164 vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
165 -- THINKME: unpack.c(read_decorr_terms) reverses the
166 -- order only when they are decoding. I don't know why so
167 -- I leave it unreversed for now.
168 return $ DecorrTerms vec
170 unpackDT ∷ Word8 → (Int8, Int8)
172 = let term = (fromIntegral $ w .&. 0x1F) - 5
173 δ = fromIntegral $ (w `shiftR` 5) .&. 0x07
177 -- | Decorrelation weights.
180 -- | For mono blocks, this is a weight vector for the single
181 -- channel. For stereo blocks, it's interleaved as A, B, A, B,
183 decwVec ∷ !(UV.Vector Int16)
185 deriving (Eq, Show, Typeable)
187 instance Metadata DecorrWeights where
189 metaSize = fromIntegral ∘ UV.length ∘ decwVec
191 instance Binary DecorrWeights where
192 put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
193 get = do n ← remaining
194 vec ← UV.replicateM (fromIntegral n)
195 $ fmap unpackWeight getWord8
196 -- THINKME: the same caution as DecorrTerms, but never
197 -- try to simply reverse the vector. Think about the
199 return $ DecorrWeights vec
201 -- | Decorrelation samples
204 -- | The decorrelation sample vector stored in the metadata
205 -- as-is. Actual interpretation of the vector depends on the
206 -- number of channels and each corresponding decorrelation
208 decsVec ∷ !(UV.Vector Int32)
210 deriving (Eq, Show, Typeable)
212 instance Metadata DecorrSamples where
214 metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
216 instance Binary DecorrSamples where
217 put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
218 get = do n ← remaining
219 vec ← UV.replicateM (fromIntegral $ n `div` 2)
220 $ fmap (exp2s ∘ fromIntegral) getWord16le
221 return $ DecorrSamples vec
223 -- | Median log2 values.
226 -- | Median log2 values for channel A, which always exists.
227 entVarA ∷ !(Word32, Word32, Word32)
228 -- | Median log2 values for channel B, which is absent when it's
230 , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
232 deriving (Eq, Show, Typeable)
234 instance Metadata EntropyVars where
237 | S.isNothing $ entVarB ev = 6
240 instance Binary EntropyVars where
242 = do putMedians $ entVarA ev
244 S.Nothing → return ()
245 S.Just medsB → putMedians medsB
247 -- THINKME: words.c(write_entropy_vars) is a destructive
248 -- subroutine. It calls read_entropy_vars() to read the
249 -- values back to compensate for the loss through the log
251 putMedians ∷ (Word32, Word32, Word32) → Put
252 putMedians (med0, med1, med2)
253 = do putWord16le $ log2 med0
254 putWord16le $ log2 med1
255 putWord16le $ log2 med2
257 get = do medsA ← getMedians
258 medsB ← do isMono ← isEmpty
262 fmap S.Just getMedians
263 return $! EntropyVars medsA medsB
265 getMedians ∷ Get (Word32, Word32, Word32)
267 = do med0 ← fmap exp2 getWord16le
268 med1 ← fmap exp2 getWord16le
269 med2 ← fmap exp2 getWord16le
270 return (med0, med1, med2)
272 -- | RIFF header for .wav files (before audio)
275 riffHeader ∷ L.ByteString
277 deriving (Eq, Show, Typeable)
279 instance Metadata RIFFHeader where
282 instance Binary RIFFHeader where
283 put = putLazyByteString ∘ riffHeader
284 get = fmap RIFFHeader getRemainingLazyByteString
286 -- | RIFF trailer for .wav files (after audio)
289 riffTrailer ∷ L.ByteString
291 deriving (Eq, Show, Typeable)
293 instance Metadata RIFFTrailer where
296 instance Binary RIFFTrailer where
297 put = putLazyByteString ∘ riffTrailer
298 get = fmap RIFFTrailer getRemainingLazyByteString
300 -- | Configuration information.
305 -- | high quality mode
308 , cfgVeryHigh ∷ !Bool
309 -- | bitrate is kbps, not bits / sample
310 , cfgBitrateKbps ∷ !Bool
311 -- | automatic noise shaping
312 , cfgAutoShaping ∷ !Bool
313 -- | shaping mode specified
314 , cfgShapeOverride ∷ !Bool
315 -- | joint-stereo mode specified
316 , cfgJointOverride ∷ !Bool
317 -- | dynamic noise shaping
318 , cfgDynamicShaping ∷ !Bool
319 -- | create executable
320 , cfgCreateEXE ∷ !Bool
321 -- | create correction file
322 , cfgCreateWVC ∷ !Bool
323 -- | maximize hybrid compression
324 , cfgOptimizeWVC ∷ !Bool
325 -- | calc noise in hybrid mode
326 , cfgCalcNoise ∷ !Bool
327 -- | obsolete (for information)
328 , cfgLossyMode ∷ !Bool
329 -- | extra processing mode level (1-6)
330 , cfgExtraModeLevel ∷ !(S.Maybe Word8)
331 -- | no wvx stream w/ floats & big ints
333 -- | compute & store MD5 signature
334 , cfgMD5Checksum ∷ !Bool
335 -- | merge blocks of equal redundancy
336 , cfgMergeBlocks ∷ !Bool
337 -- | optimize for mono streams posing
338 , cfgOptimizeMono ∷ !Bool
340 deriving (Eq, Show, Typeable)
342 instance Metadata ConfigInfo where
345 | S.isJust $ cfgExtraModeLevel ci
350 instance Binary ConfigInfo where
352 = let !bs = runBitPut $
353 do putBit $ cfgOptimizeMono ci
354 putNBits 2 (0 ∷ Word8) -- unused
355 putBit $ cfgMergeBlocks ci
356 putBit $ cfgMD5Checksum ci
357 putBit $ cfgSkipWVX ci
358 putBit $ S.isJust $ cfgExtraModeLevel ci
359 putBit $ cfgLossyMode ci
360 putBit $ cfgCalcNoise ci
361 putNBits 2 (0 ∷ Word8) -- unused
362 putBit $ cfgOptimizeWVC ci
363 putBit $ cfgCreateWVC ci
364 putBit $ cfgCreateEXE ci
365 putBit $ cfgDynamicShaping ci
366 putBit $ cfgJointOverride ci
367 putBit $ cfgShapeOverride ci
368 putBit $ cfgAutoShaping ci
369 putBit $ cfgBitrateKbps ci
370 putBit $ cfgVeryHigh ci
372 putBit False -- unused
374 putBit False -- unused
376 do putLazyByteString (L.reverse bs)
377 case cfgExtraModeLevel ci of
378 S.Nothing → return ()
379 S.Just eml → putWord8 eml
381 get = do bs ← getBytes 3
382 eml ← do xmode ← fmap (¬) isEmpty
387 let r = runBitGet (S.reverse bs) $
388 do optimizeMono ← getBit
400 dynamicShaping ← getBit
401 jointOverride ← getBit
402 shapeOverride ← getBit
413 , cfgVeryHigh = veryHigh
414 , cfgBitrateKbps = bitrateKbps
415 , cfgAutoShaping = autoShaping
416 , cfgShapeOverride = shapeOverride
417 , cfgJointOverride = jointOverride
418 , cfgDynamicShaping = dynamicShaping
419 , cfgCreateEXE = createEXE
420 , cfgCreateWVC = createWVC
421 , cfgOptimizeWVC = optimizeWVC
422 , cfgCalcNoise = calcNoise
423 , cfgLossyMode = lossyMode
424 , cfgExtraModeLevel = if extraMode then
428 , cfgSkipWVX = skipWVX
429 , cfgMD5Checksum = md5Checksum
430 , cfgMergeBlocks = mergeBlocks
431 , cfgOptimizeMono = optimizeMono
438 -- | Unknown but optional metadata found in the WavPack block.
441 -- | The ID of this unknown metadata without odd-size bit nor
444 -- | Raw data; must be less than 2^25 bytes long.
445 , unkData ∷ L.ByteString
447 deriving (Eq, Show, Typeable)
449 instance Metadata Unknown where
452 instance Binary Unknown where
453 put = putLazyByteString ∘ unkData
454 get = error "unsupported operation"