]> gitweb @ CieloNegro.org - wavpack.git/blob - Codec/Audio/WavPack/Metadata.hs
haddock comments
[wavpack.git] / Codec / Audio / WavPack / Metadata.hs
1 {-# LANGUAGE
2     DeriveDataTypeable
3   , ExistentialQuantification
4   , UnicodeSyntax
5   #-}
6 -- | WavPack metadata sub-blocks
7 module Codec.Audio.WavPack.Metadata
8     ( Metadata(..)
9     , SubBlock
10
11     , Dummy(..)
12     , DecorrTerms(..)
13     , DecorrWeights(..)
14     , DecorrSamples(..)
15     , EntropyVars(..)
16     , WVBitstream(..)
17     , RIFFHeader(..)
18     , RIFFTrailer(..)
19     , ConfigInfo(..)
20     , Unknown(..)
21     )
22     where
23 import qualified Codec.Audio.WavPack.BitString as B
24 import Codec.Audio.WavPack.Internal
25 import Control.Monad
26 import Data.Binary
27 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
28 import Data.Binary.Get
29 import Data.Binary.Put
30 import Data.Binary.Strict.BitGet (getBit, runBitGet)
31 import qualified Data.Binary.Strict.BitGet as BG
32 import Data.Bits
33 import qualified Data.ByteString as S
34 import qualified Data.ByteString.Lazy as L
35 import Data.Int
36 import qualified Data.Strict as S
37 import Data.Typeable
38 import qualified Data.Vector.Unboxed as UV
39 import Prelude.Unicode
40
41 -- | Type class for every metadata sub-blocks.
42 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
43     -- | Get the metadata ID without odd-size bit nor large-block bit
44     -- (mandatory).
45     metaID   ∷ α → Word8
46     -- | Get the size of metadata, excluding the metadata header
47     -- (optional).
48     metaSize ∷ α → Word32
49     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
50     -- | Cast a 'SubBlock' to this type of metadata (optional).
51     fromSubBlock ∷ SubBlock → Maybe α
52     fromSubBlock (SubBlock a) = cast a
53     -- | Wrap the metadata into 'SubBlock' (optional).
54     toSubBlock ∷ α → SubBlock
55     toSubBlock = SubBlock
56
57 -- | An opaque sub-block container.
58 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
59                 deriving Typeable
60
61 instance Metadata SubBlock where
62     metaID   (SubBlock a) = metaID a
63     metaSize (SubBlock a) = metaSize a
64     fromSubBlock = Just
65     toSubBlock   = id
66
67 instance Binary SubBlock where
68     put (SubBlock a)
69         = let size     = metaSize a
70               size'    = size + 1
71               oddBit   = if odd size     then 0x40 else 0
72               largeBit = if size > 0x1FE then 0x80 else 0
73               idWord   = metaID a .|. oddBit .|. largeBit
74           in
75             do putWord8 idWord
76                if size > 0x1FE then
77                    -- Don't forget about the endianness.
78                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
79                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
80                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
81                  else
82                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
83                put a
84                when (odd size) $ putWord8 0
85
86     get = do idWord ← getWord8
87              let isOdd   = idWord .&. 0x40 ≢ 0
88                  isLarge = idWord .&. 0x80 ≢ 0
89                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
90                  adj     = if isOdd then -1 else 0
91              size ← if isLarge then
92                          do sz0 ← getWord8
93                             sz1 ← getWord8
94                             sz2 ← getWord8
95                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
96                                        (fromIntegral sz1 `shiftL`  9) .|.
97                                        (fromIntegral sz0 `shiftL`  1)
98                                      ) + adj
99                      else
100                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
101              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
102              return $ runGet (getSubBlock rawID) subb
103         where
104           getSubBlock ∷ Word8 → Get SubBlock
105           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy        )
106           getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms  )
107           getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
108           getSubBlock 0x04 = fmap SubBlock (get ∷ Get DecorrSamples)
109           getSubBlock 0x05 = fmap SubBlock (get ∷ Get EntropyVars  )
110           getSubBlock 0x0A = fmap SubBlock (get ∷ Get WVBitstream  )
111           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader   )
112           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer  )
113           getSubBlock 0x25 = fmap SubBlock (get ∷ Get ConfigInfo   )
114           getSubBlock unknownID
115               = if unknownID .&. 0x20 ≡ 0 then
116                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
117                 else
118                     -- It's unknown but optional. We can safely ignore it.
119                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
120
121 instance Eq SubBlock where
122     (SubBlock a) == (SubBlock b)
123         = Just a ≡ cast b
124
125 instance Show SubBlock where
126     show (SubBlock a) = show a
127
128 -- | Dummy metadata to pad WavPack blocks.
129 data Dummy
130     = Dummy {
131         -- | Must be less than 2^25 bytes long due to the limitation
132         -- of WavPack specification.
133         dumSize ∷ !Word32
134       }
135     deriving (Eq, Show, Typeable)
136
137 instance Metadata Dummy where
138     metaID _ = 0x00
139     metaSize = dumSize
140
141 instance Binary Dummy where
142     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
143     get = fmap (Dummy ∘ fromIntegral) remaining
144
145 -- | Decorrelation terms and deltas.
146 data DecorrTerms
147     = DecorrTerms {
148         -- | @[ (term, delta) ]@
149         dectVec ∷ !(UV.Vector (Int8, Int8))
150       }
151     deriving (Eq, Show, Typeable)
152
153 instance Metadata DecorrTerms where
154     metaID _ = 0x02
155     metaSize = fromIntegral ∘ UV.length ∘ dectVec
156
157 instance Binary DecorrTerms where
158     put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
159         where
160           packDT ∷ (Int8, Int8) → Word8
161           packDT (term, δ)
162               = fromIntegral ( (term + 5 .&. 0x1F)
163                                .|.
164                                ((δ `shiftL` 5) .&. 0xE0)
165                              )
166     get = do n   ← remaining
167              vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
168              -- THINKME: unpack.c(read_decorr_terms) reverses the
169              -- order only when they are decoding. I don't know why so
170              -- I leave it unreversed for now.
171              return $ DecorrTerms vec
172         where
173           unpackDT ∷ Word8 → (Int8, Int8)
174           unpackDT w
175               = let term = (fromIntegral $ w .&. 0x1F) - 5
176                     δ    = fromIntegral $ (w `shiftR` 5) .&. 0x07
177                 in
178                   (term, δ)
179
180 -- | Decorrelation weights.
181 data DecorrWeights
182     = DecorrWeights {
183       -- | For mono blocks, this is a weight vector for the single
184       --   channel. For stereo blocks, it's interleaved as A, B, A, B,
185       --   ...
186         decwVec ∷ !(UV.Vector Int16)
187       }
188     deriving (Eq, Show, Typeable)
189
190 instance Metadata DecorrWeights where
191     metaID _ = 0x03
192     metaSize = fromIntegral ∘ UV.length ∘ decwVec
193
194 instance Binary DecorrWeights where
195     put = UV.mapM_ (putWord8 ∘ packWeight) ∘ decwVec
196     get = do n   ← remaining
197              vec ← UV.replicateM (fromIntegral n)
198                     $ fmap unpackWeight getWord8
199              -- THINKME: the same caution as DecorrTerms, but never
200              -- try to simply reverse the vector. Think about the
201              -- interleaving.
202              return $ DecorrWeights vec
203
204 -- | Decorrelation samples
205 data DecorrSamples
206     = DecorrSamples {
207       -- | The decorrelation sample vector stored in the metadata
208       --   as-is. Actual interpretation of the vector depends on the
209       --   number of channels and each corresponding decorrelation
210       --   terms.
211         decsVec ∷ !(UV.Vector Int32)
212       }
213     deriving (Eq, Show, Typeable)
214
215 instance Metadata DecorrSamples where
216     metaID _ = 0x04
217     metaSize = fromIntegral ∘ (⋅ 2) ∘ UV.length ∘ decsVec
218
219 instance Binary DecorrSamples where
220     put = UV.mapM_ (putWord16le ∘ fromIntegral ∘ log2s) ∘ decsVec
221     get = do n   ← remaining
222              vec ← UV.replicateM (fromIntegral $ n `div` 2)
223                     $ fmap (exp2s ∘ fromIntegral) getWord16le
224              return $ DecorrSamples vec
225
226 -- | Median log2 values.
227 data EntropyVars
228     = EntropyVars {
229       -- | Median log2 values for channel A, which always exists.
230         entVarA ∷ !(Word32, Word32, Word32)
231       -- | Median log2 values for channel B, which is absent when it's
232       --   mono.
233       , entVarB ∷ !(S.Maybe (Word32, Word32, Word32))
234       }
235     deriving (Eq, Show, Typeable)
236
237 instance Metadata EntropyVars where
238     metaID _ = 0x05
239     metaSize ev
240         | S.isNothing $ entVarB ev =  6
241         | otherwise                = 12
242
243 instance Binary EntropyVars where
244     put ev
245         = do putMedians $ entVarA ev
246              case entVarB ev of
247                S.Nothing    → return ()
248                S.Just medsB → putMedians medsB
249         where
250           -- THINKME: words.c(write_entropy_vars) is a destructive
251           -- subroutine. It calls read_entropy_vars() to read the
252           -- values back to compensate for the loss through the log
253           -- function.
254           putMedians ∷ (Word32, Word32, Word32) → Put
255           putMedians (med0, med1, med2)
256               = do putWord16le $ log2 med0
257                    putWord16le $ log2 med1
258                    putWord16le $ log2 med2
259
260     get = do medsA ← getMedians
261              medsB ← do isMono ← isEmpty
262                         if isMono then
263                             return S.Nothing
264                           else
265                             fmap S.Just getMedians
266              return $! EntropyVars medsA medsB
267         where
268           getMedians ∷ Get (Word32, Word32, Word32)
269           getMedians
270               = do med0 ← fmap exp2 getWord16le
271                    med1 ← fmap exp2 getWord16le
272                    med2 ← fmap exp2 getWord16le
273                    return (med0, med1, med2)
274
275 -- | WV Bitstream
276 data WVBitstream
277     = WVBitstream {
278         wvStream ∷ !B.BitString
279       }
280     deriving (Eq, Show, Typeable)
281
282 instance Metadata WVBitstream where
283     metaID _ = 0x0A
284     metaSize = (`div` 8) ∘ B.length ∘ wvStream
285
286 instance Binary WVBitstream where
287     put = putLazyByteString ∘ B.toByteString ∘ wvStream
288     get = fmap (WVBitstream ∘ B.fromByteString) getRemainingLazyByteString
289
290 -- | RIFF header for .wav files (before audio)
291 data RIFFHeader
292     = RIFFHeader {
293         riffHeader ∷ !L.ByteString
294       }
295     deriving (Eq, Show, Typeable)
296
297 instance Metadata RIFFHeader where
298     metaID _ = 0x21
299     metaSize = fromIntegral ∘ L.length ∘ riffHeader
300
301 instance Binary RIFFHeader where
302     put = putLazyByteString ∘ riffHeader
303     get = fmap RIFFHeader getRemainingLazyByteString
304
305 -- | RIFF trailer for .wav files (after audio)
306 data RIFFTrailer
307     = RIFFTrailer {
308         riffTrailer ∷ !L.ByteString
309       }
310     deriving (Eq, Show, Typeable)
311
312 instance Metadata RIFFTrailer where
313     metaID _ = 0x22
314     metaSize = fromIntegral ∘ L.length ∘ riffTrailer
315
316 instance Binary RIFFTrailer where
317     put = putLazyByteString ∘ riffTrailer
318     get = fmap RIFFTrailer getRemainingLazyByteString
319
320 -- | Configuration information.
321 data ConfigInfo
322     = ConfigInfo {
323       -- | fast mode
324         cfgFast           ∷ !Bool
325       -- | high quality mode
326       , cfgHigh           ∷ !Bool
327       -- | very high
328       , cfgVeryHigh       ∷ !Bool
329       -- | bitrate is kbps, not bits / sample
330       , cfgBitrateKbps    ∷ !Bool
331       -- | automatic noise shaping
332       , cfgAutoShaping    ∷ !Bool
333       -- | shaping mode specified
334       , cfgShapeOverride  ∷ !Bool
335       -- | joint-stereo mode specified
336       , cfgJointOverride  ∷ !Bool
337       -- | dynamic noise shaping
338       , cfgDynamicShaping ∷ !Bool
339       -- | create executable
340       , cfgCreateEXE      ∷ !Bool
341       -- | create correction file
342       , cfgCreateWVC      ∷ !Bool
343       -- | maximize hybrid compression
344       , cfgOptimizeWVC    ∷ !Bool
345       -- | calc noise in hybrid mode
346       , cfgCalcNoise      ∷ !Bool
347       -- | obsolete (for information)
348       , cfgLossyMode      ∷ !Bool
349       -- | extra processing mode level (1-6)
350       , cfgExtraModeLevel ∷ !(S.Maybe Word8)
351       -- | no wvx stream w/ floats & big ints
352       , cfgSkipWVX        ∷ !Bool
353       -- | compute & store MD5 signature
354       , cfgMD5Checksum    ∷ !Bool
355       -- | merge blocks of equal redundancy
356       , cfgMergeBlocks    ∷ !Bool
357       -- | optimize for mono streams posing
358       , cfgOptimizeMono   ∷ !Bool
359       }
360     deriving (Eq, Show, Typeable)
361
362 instance Metadata ConfigInfo where
363     metaID _ = 0x25
364     metaSize ci
365         | S.isJust $ cfgExtraModeLevel ci
366             = 4
367         | otherwise
368             = 3
369
370 instance Binary ConfigInfo where
371     put ci
372         = let !bs = runBitPut $
373                     do putBit $ cfgOptimizeMono   ci
374                        putNBits 2 (0 ∷ Word8) -- unused
375                        putBit $ cfgMergeBlocks    ci
376                        putBit $ cfgMD5Checksum    ci
377                        putBit $ cfgSkipWVX        ci
378                        putBit $ S.isJust $ cfgExtraModeLevel ci
379                        putBit $ cfgLossyMode      ci
380                        putBit $ cfgCalcNoise      ci
381                        putNBits 2 (0 ∷ Word8) -- unused
382                        putBit $ cfgOptimizeWVC    ci
383                        putBit $ cfgCreateWVC      ci
384                        putBit $ cfgCreateEXE      ci
385                        putBit $ cfgDynamicShaping ci
386                        putBit $ cfgJointOverride  ci
387                        putBit $ cfgShapeOverride  ci
388                        putBit $ cfgAutoShaping    ci
389                        putBit $ cfgBitrateKbps    ci
390                        putBit $ cfgVeryHigh       ci
391                        putBit $ cfgHigh           ci
392                        putBit False -- unused
393                        putBit $ cfgFast           ci
394                        putBit False -- unused
395           in
396             do putLazyByteString (L.reverse bs)
397                case cfgExtraModeLevel ci of
398                  S.Nothing  → return ()
399                  S.Just eml → putWord8 eml
400
401     get = do bs  ← getBytes 3
402              eml ← do xmode ← fmap (¬) isEmpty
403                       if xmode then
404                           fmap S.Just getWord8
405                         else
406                           return S.Nothing
407              let r = runBitGet (S.reverse bs) $
408                      do optimizeMono   ← getBit
409                         BG.skip 2 -- unused
410                         mergeBlocks    ← getBit
411                         md5Checksum    ← getBit
412                         skipWVX        ← getBit
413                         extraMode      ← getBit
414                         lossyMode      ← getBit
415                         calcNoise      ← getBit
416                         BG.skip 2 -- unused
417                         optimizeWVC    ← getBit
418                         createWVC      ← getBit
419                         createEXE      ← getBit
420                         dynamicShaping ← getBit
421                         jointOverride  ← getBit
422                         shapeOverride  ← getBit
423                         autoShaping    ← getBit
424                         bitrateKbps    ← getBit
425                         veryHigh       ← getBit
426                         high           ← getBit
427                         BG.skip 1 -- unused
428                         fast           ← getBit
429                         BG.skip 1 -- unused
430                         return ConfigInfo {
431                                      cfgFast           = fast
432                                    , cfgHigh           = high
433                                    , cfgVeryHigh       = veryHigh
434                                    , cfgBitrateKbps    = bitrateKbps
435                                    , cfgAutoShaping    = autoShaping
436                                    , cfgShapeOverride  = shapeOverride
437                                    , cfgJointOverride  = jointOverride
438                                    , cfgDynamicShaping = dynamicShaping
439                                    , cfgCreateEXE      = createEXE
440                                    , cfgCreateWVC      = createWVC
441                                    , cfgOptimizeWVC    = optimizeWVC
442                                    , cfgCalcNoise      = calcNoise
443                                    , cfgLossyMode      = lossyMode
444                                    , cfgExtraModeLevel = if extraMode then
445                                                              eml
446                                                          else
447                                                              S.Nothing
448                                    , cfgSkipWVX        = skipWVX
449                                    , cfgMD5Checksum    = md5Checksum
450                                    , cfgMergeBlocks    = mergeBlocks
451                                    , cfgOptimizeMono   = optimizeMono
452                                    }
453                          
454              case r of
455                Left err → fail err
456                Right ci → return ci
457
458 -- | Unknown but optional metadata found in the WavPack block.
459 data Unknown
460     = Unknown {
461         -- | The ID of this unknown metadata without odd-size bit nor
462         -- large-block bit.
463         unkID   ∷ Word8
464         -- | Raw data; must be less than 2^25 bytes long.
465       , unkData ∷ L.ByteString
466       }
467     deriving (Eq, Show, Typeable)
468
469 instance Metadata Unknown where
470     metaID   = unkID
471
472 instance Binary Unknown where
473     put = putLazyByteString ∘ unkData
474     get = error "unsupported operation"