]> gitweb @ CieloNegro.org - wavpack.git/blob - Codec/Audio/WavPack/Metadata.hs
d8c0df1e592d889c1b203acb5a2ef3dd99d790f5
[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     , RIFFHeader(..)
15     , RIFFTrailer(..)
16     , Unknown(..)
17     )
18     where
19 import Control.Monad
20 import Data.Binary
21 import Data.Binary.Get
22 import Data.Binary.Put
23 import Data.Bits
24 import qualified Data.ByteString.Lazy as L
25 import Data.Int
26 import Data.Typeable
27 import qualified Data.Vector.Unboxed as UV
28 import Prelude.Unicode
29
30 -- | Type class for every metadata sub-blocks.
31 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
32     -- | Get the metadata ID without odd-size bit nor large-block bit
33     -- (mandatory).
34     metaID   ∷ α → Word8
35     -- | Get the size of metadata, excluding the metadata header
36     -- (optional).
37     metaSize ∷ α → Word32
38     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
39     -- | Cast a 'SubBlock' to this type of metadata (optional).
40     fromSubBlock ∷ SubBlock → Maybe α
41     fromSubBlock (SubBlock a) = cast a
42     -- | Wrap the metadata into 'SubBlock' (optional).
43     toSubBlock ∷ α → SubBlock
44     toSubBlock = SubBlock
45
46 -- | An opaque sub-block container.
47 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
48                 deriving Typeable
49
50 instance Metadata SubBlock where
51     metaID   (SubBlock a) = metaID a
52     metaSize (SubBlock a) = metaSize a
53     fromSubBlock = Just
54     toSubBlock   = id
55
56 instance Binary SubBlock where
57     put (SubBlock a)
58         = let size     = metaSize a
59               size'    = size + 1
60               oddBit   = if odd size     then 0x40 else 0
61               largeBit = if size > 0x1FE then 0x80 else 0
62               idWord   = metaID a .|. oddBit .|. largeBit
63           in
64             do putWord8 idWord
65                if size > 0x1FE then
66                    -- Don't forget about the endianness.
67                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
68                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
69                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
70                  else
71                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
72                put a
73                when (odd size) $ putWord8 0
74
75     get = do idWord ← getWord8
76              let isOdd   = idWord .&. 0x40 ≢ 0
77                  isLarge = idWord .&. 0x80 ≢ 0
78                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
79                  adj     = if isOdd then -1 else 0
80              size ← if isLarge then
81                          do sz0 ← getWord8
82                             sz1 ← getWord8
83                             sz2 ← getWord8
84                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
85                                        (fromIntegral sz1 `shiftL`  9) .|.
86                                        (fromIntegral sz0 `shiftL`  1)
87                                      ) + adj
88                      else
89                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
90              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
91              return $ runGet (getSubBlock rawID) subb
92         where
93           getSubBlock ∷ Word8 → Get SubBlock
94           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy        )
95           getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms  )
96           getSubBlock 0x03 = fmap SubBlock (get ∷ Get DecorrWeights)
97           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader   )
98           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer  )
99           getSubBlock unknownID
100               = if unknownID .&. 0x20 ≡ 0 then
101                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
102                 else
103                     -- It's unknown but optional. We can safely ignore it.
104                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
105
106 instance Eq SubBlock where
107     (SubBlock a) == (SubBlock b)
108         = Just a ≡ cast b
109
110 instance Show SubBlock where
111     show (SubBlock a) = show a
112
113 -- | Dummy metadata to pad WavPack blocks.
114 data Dummy
115     = Dummy {
116         -- | Must be less than 2^25 bytes long due to the limitation
117         -- of WavPack specification.
118         dumSize ∷ Word32
119       }
120     deriving (Eq, Show, Typeable)
121
122 instance Metadata Dummy where
123     metaID _ = 0x00
124     metaSize = dumSize
125
126 instance Binary Dummy where
127     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
128     get = fmap (Dummy ∘ fromIntegral) remaining
129
130 -- | Decorrelation terms and deltas.
131 data DecorrTerms
132     = DecorrTerms {
133         -- | @[ (term, delta) ]@
134         dectVec ∷ !(UV.Vector (Int8, Int8))
135       }
136     deriving (Eq, Show, Typeable)
137
138 instance Metadata DecorrTerms where
139     metaID _ = 0x02
140     metaSize = fromIntegral ∘ UV.length ∘ dectVec
141
142 instance Binary DecorrTerms where
143     put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
144         where
145           packDT ∷ (Int8, Int8) → Word8
146           packDT (term, δ)
147               = fromIntegral ( (term + 5 .&. 0x1F)
148                                .|.
149                                ((δ `shiftL` 5) .&. 0xE0)
150                              )
151     get = do n   ← remaining
152              vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
153              -- THINKME: unpack.c(read_decorr_terms) reverses the
154              -- order only when they are decoding. I don't know why so
155              -- I leave it unreversed for now.
156              return $ DecorrTerms vec
157         where
158           unpackDT ∷ Word8 → (Int8, Int8)
159           unpackDT w
160               = let term = (fromIntegral $ w .&. 0x1F) - 5
161                     δ    = fromIntegral $ (w `shiftR` 5) .&. 0x07
162                 in
163                   (term, δ)
164
165 -- | Decorrelation weights.
166 data DecorrWeights
167     = DecorrWeights {
168       -- | For mono blocks, this is a weight vector for the single
169       --   channel. For stereo blocks, it's interleaved as A, B, A, B,
170       --   ...
171         decwVec ∷ !(UV.Vector Int16)
172       }
173     deriving (Eq, Show, Typeable)
174
175 instance Metadata DecorrWeights where
176     metaID _ = 0x03
177     metaSize = fromIntegral ∘ UV.length ∘ decwVec
178
179 instance Binary DecorrWeights where
180     put = UV.mapM_ (putWord8 ∘ packW) ∘ decwVec
181         where
182           packW ∷ Int16 → Word8
183           packW w
184               = let w'   | w  >  1024 =  1024
185                          | w  < -1024 = -1024
186                          | otherwise  =     w
187                     w''  | w' >     0 = w' - ((w' + 64) `shiftR` 7)
188                          | otherwise  = w'
189                     w'''              = (w'' + 4) `shiftR` 3
190                 in
191                   fromIntegral w'''
192     get = do n   ← remaining
193              vec ← UV.replicateM (fromIntegral n) $ fmap unpackW getWord8
194              -- THINKME: the same caution as DecorrTerms, but never
195              -- try to reverse the vector simply. Think about the
196              -- interleaving.
197              return $ DecorrWeights vec
198         where
199           unpackW ∷ Word8 → Int16
200           unpackW w
201               = let w'  ∷ Int8
202                     w'  = fromIntegral w
203                     w'' ∷ Int16
204                     w'' = (fromIntegral w') `shiftL` 3
205                     w''' | w'' > 0   = w'' + ((w'' + 64) `shiftR` 7)
206                          | otherwise = w''
207                 in
208                   w'''
209
210 -- | RIFF header for .wav files (before audio)
211 data RIFFHeader
212     = RIFFHeader {
213         riffHeader ∷ L.ByteString
214       }
215     deriving (Eq, Show, Typeable)
216
217 instance Metadata RIFFHeader where
218     metaID _ = 0x21
219
220 instance Binary RIFFHeader where
221     put = putLazyByteString ∘ riffHeader
222     get = fmap RIFFHeader getRemainingLazyByteString
223
224 -- | RIFF trailer for .wav files (after audio)
225 data RIFFTrailer
226     = RIFFTrailer {
227         riffTrailer ∷ L.ByteString
228       }
229     deriving (Eq, Show, Typeable)
230
231 instance Metadata RIFFTrailer where
232     metaID _ = 0x22
233
234 instance Binary RIFFTrailer where
235     put = putLazyByteString ∘ riffTrailer
236     get = fmap RIFFTrailer getRemainingLazyByteString
237
238 -- | Unknown but optional metadata found in the WavPack block.
239 data Unknown
240     = Unknown {
241         -- | The ID of this unknown metadata without odd-size bit nor
242         -- large-block bit.
243         unkID   ∷ Word8
244         -- | Raw data; must be less than 2^25 bytes long.
245       , unkData ∷ L.ByteString
246       }
247     deriving (Eq, Show, Typeable)
248
249 instance Metadata Unknown where
250     metaID   = unkID
251
252 instance Binary Unknown where
253     put = putLazyByteString ∘ unkData
254     get = error "unsupported operation"