]> gitweb @ CieloNegro.org - wavpack.git/blob - Codec/Audio/WavPack/Block.hs
haddock comments
[wavpack.git] / Codec / Audio / WavPack / Block.hs
1 {-# LANGUAGE
2     BangPatterns
3   , UnboxedTuples
4   , UnicodeSyntax
5   #-}
6 -- | WavPack blocks
7 module Codec.Audio.WavPack.Block
8     ( Block(..)
9     , BlockHeader(..)
10     , BlockFlags(..)
11
12     , readBlocks
13     )
14     where
15 import Codec.Audio.WavPack.Metadata
16 import Data.Binary
17 import Data.Binary.BitPut (putBit, putNBits, runBitPut)
18 import Data.Binary.Get
19 import Data.Binary.Put
20 import Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet)
21 import qualified Data.Binary.Strict.BitGet as BG
22 import qualified Data.ByteString as S
23 import qualified Data.ByteString.Lazy as L
24 import qualified Data.Strict as S
25 import Prelude.Unicode
26
27 -- | The WavPack block.
28 data Block
29     = Block {
30         blockHeader   ∷ !BlockHeader
31       , blockMetadata ∷ [SubBlock]
32       }
33     deriving (Show, Eq)
34
35 instance Binary Block where
36     put b
37         = do put $ blockHeader b
38              mapM_ put $ blockMetadata b
39
40     get = do header ← get
41              subs   ← getSubBlocks (bhSize header)
42              return $! Block {
43                           blockHeader   = header
44                         , blockMetadata = subs
45                         }
46
47 -- Be aware; the Get monad is like a strict State monad so the entire
48 -- sub-blocks are parsed at once. This might not be what you want
49 -- (like me).
50 getSubBlocks ∷ Integral n ⇒ n → Get [SubBlock]
51 getSubBlocks 0 = return $! []
52 getSubBlocks !blockSize
53     = do before ← bytesRead
54          meta   ← get
55          after  ← bytesRead
56          rest   ← getSubBlocks $ blockSize - fromIntegral (after - before)
57          return (meta : rest)
58
59 -- The lazy version.
60 getSubBlocksLazily ∷ Integral n
61                    ⇒ L.ByteString
62                    → n
63                    → (# [SubBlock], L.ByteString #)
64 getSubBlocksLazily src          0 = (# [], src #)
65 getSubBlocksLazily src !blockSize
66     = let (sub, src', consumed)
67               = runGetState get src 0
68           (# subs, src'' #)
69               = getSubBlocksLazily src' $
70                 blockSize - fromIntegral consumed
71       in
72         (# sub : subs, src'' #)
73
74 -- | The preamble to every block in both the .wv and .wvc files.
75 data BlockHeader
76     = BlockHeader {
77       -- | size of entire block (excluding the header)
78         bhSize         ∷ !Word32
79       -- | 0x402 to 0x410 are currently valid for decode
80       , bhVersion      ∷ !Word16
81       -- | track number (0 if not used, like now)
82       , bhTrackNo      ∷ !Word8
83       -- | track sub-index (0 if not used, like now)
84       , bhIndexNo      ∷ !Word8
85       -- | total samples for entire file, but this is only valid if
86       --   'bhBlockIndex' == 0 and a value of -1 indicates unknown
87       --   length
88       , bhTotalSamples ∷ !Word32
89       -- | index of first sample in block relative to beginning of
90       --   file (normally this would start at 0 for the first block)
91       , bhBlockIndex   ∷ !Word32
92       -- | number of samples in this block (0 = no audio)
93       , bhBlockSamples ∷ !Word32
94       -- | various flags for id and decoding
95       , bhFlags        ∷ !BlockFlags
96       -- | crc for actual decoded data
97       , bhCRC          ∷ !Word32
98       }
99     deriving (Show, Eq)
100
101 instance Binary BlockHeader where
102     put bh
103         = do putWord8 119 -- 'w'
104              putWord8 118 -- 'v'
105              putWord8 112 -- 'p'
106              putWord8 107 -- 'k'
107              putWord32le $ bhSize         bh + 32 - 8
108              putWord16le $ bhVersion      bh
109              putWord8    $ bhTrackNo      bh
110              putWord8    $ bhIndexNo      bh
111              putWord32le $ bhTotalSamples bh
112              putWord32le $ bhBlockIndex   bh
113              putWord32le $ bhBlockSamples bh
114              put         $ bhFlags        bh
115              putWord32le $ bhCRC          bh
116
117     get = do skip 4 -- "wvpk"
118              size         ← getWord32le
119              version      ← getWord16le
120              trackNo      ← getWord8
121              indexNo      ← getWord8
122              totalSamples ← getWord32le
123              blockIndex   ← getWord32le
124              blockSamples ← getWord32le
125              flags        ← get
126              crc          ← getWord32le
127              return $! BlockHeader {
128                               bhSize         = size + 8 - 32
129                             , bhVersion      = version
130                             , bhTrackNo      = trackNo
131                             , bhIndexNo      = indexNo
132                             , bhTotalSamples = totalSamples
133                             , bhBlockIndex   = blockIndex
134                             , bhBlockSamples = blockSamples
135                             , bhFlags        = flags
136                             , bhCRC          = crc
137                             }
138
139 -- | Various flags for decoding blocks
140 data BlockFlags
141     = BlockFlags {
142       -- | 1 <= n <= 4
143         bfBytesPerSample ∷ !Word8
144       -- | 'False' = stereo output; 'True' = mono output
145       , bfMono           ∷ !Bool
146       -- | 'False' = lossless mode; 'True' = hybrid mode
147       , bfHybrid         ∷ !Bool
148       -- | 'False' = true stereo; 'True' = joint stereo (mid/side)
149       , bfJointStereo    ∷ !Bool
150       -- | 'False' = independent channels; 'True' = cross-channel
151       --   decorrelation
152       , bfCrossDecorr    ∷ !Bool
153       -- | 'False' = flat noise spectrum in hybrid; 'True' = hybrid
154       --   noise shaping
155       , bfHybridShape    ∷ !Bool
156       -- | 'False' = integer data; 'True' = floating point data
157       , bfFloatData      ∷ !Bool
158       -- | 'True' = extended size integers (> 24-bit); 'False' =
159       --   shifted integers
160       , bfExtendedInt    ∷ !Bool
161       -- | 'False' = hybrid mode parameters control noise level;
162       --   'True' = hybrid mode parameters control bitrate
163       , bfHybridBitrate  ∷ !Bool
164       -- | 'True' = hybrid noise balanced between channels
165       , bfHybridBalance  ∷ !Bool
166       -- | 'True' = initial block in sequence (for multichannel)
167       , bfInitialBlock   ∷ !Bool
168       -- | 'True' = final block in sequence (for multichannel)
169       , bfFinalBlock     ∷ !Bool
170       -- | amount of data left-shift after decode (0-31 places)
171       , bfLeftShift      ∷ !Word8
172       -- | maximum magnitude of decoded data (number of bits integers
173       --   require minus 1)
174       , bfMaxMagnitude   ∷ !Word8
175       -- | sampling rate ('Nothing' = unknown/custom)
176       , bfSamplingRate   ∷ !(S.Maybe Int)
177       -- | 'True' = use IIR for negative hybrid noise shaping
178       , bfIIRShaping     ∷ !Bool
179       -- | 'True' = false stereo (data is mono but output is stereo)
180       , bfFalseStereo    ∷ !Bool
181       }
182     deriving (Show, Eq)
183
184 instance Binary BlockFlags where
185     put bf
186         = let !bs = runBitPut $
187                     do putBit False -- reserved
188                        putBit $ bfFalseStereo bf
189                        putBit $ bfIIRShaping  bf
190                        putNBits 2 (0 ∷ Word8) -- reserved
191                        putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf
192                        putNBits 5 $ bfMaxMagnitude bf
193                        putNBits 5 $ bfLeftShift    bf
194                        putBit $ bfFinalBlock    bf
195                        putBit $ bfInitialBlock  bf
196                        putBit $ bfHybridBalance bf
197                        putBit $ bfHybridBitrate bf
198                        putBit $ bfExtendedInt   bf
199                        putBit $ bfFloatData     bf
200                        putBit $ bfHybridShape   bf
201                        putBit $ bfCrossDecorr   bf
202                        putBit $ bfJointStereo   bf
203                        putBit $ bfHybrid        bf
204                        putBit $ bfMono          bf
205                        putNBits 2 $! bfBytesPerSample bf - 1
206           in
207             putLazyByteString (L.reverse bs)
208
209     get = do bs ← getBytes 4
210              let !r = runBitGet (S.reverse bs) $
211                       do BG.skip 1 -- reserved
212                          falseStereo    ← getBit
213                          iirShaping     ← getBit
214                          BG.skip 2 -- reserved
215                          samplingRate   ← getAsWord8 4
216                          maxMagnitude   ← getAsWord8 5
217                          leftShift      ← getAsWord8 5
218                          finalBlock     ← getBit
219                          initialBlock   ← getBit
220                          hybridBalance  ← getBit
221                          hybridBitrate  ← getBit
222                          extendedInt    ← getBit
223                          floatData      ← getBit
224                          hybridShape    ← getBit
225                          crossDecorr    ← getBit
226                          jointStereo    ← getBit
227                          hybrid         ← getBit
228                          mono           ← getBit
229                          bytesPerSample ← getAsWord8 2
230                          return $! BlockFlags {
231                                       bfBytesPerSample = bytesPerSample + 1
232                                     , bfMono           = mono
233                                     , bfHybrid         = hybrid
234                                     , bfJointStereo    = jointStereo
235                                     , bfCrossDecorr    = crossDecorr
236                                     , bfHybridShape    = hybridShape
237                                     , bfFloatData      = floatData
238                                     , bfExtendedInt    = extendedInt
239                                     , bfHybridBitrate  = hybridBitrate
240                                     , bfHybridBalance  = hybridBalance
241                                     , bfInitialBlock   = initialBlock
242                                     , bfFinalBlock     = finalBlock
243                                     , bfLeftShift      = leftShift
244                                     , bfMaxMagnitude   = maxMagnitude
245                                     , bfSamplingRate   = decodeSamplingRate samplingRate
246                                     , bfIIRShaping     = iirShaping
247                                     , bfFalseStereo    = falseStereo
248                                     }
249              case r of
250                Left err → fail err
251                Right bf → return $! bf
252
253 encodeSamplingRate ∷ S.Maybe Int → Word8
254 encodeSamplingRate (S.Just   6000) = 0x00
255 encodeSamplingRate (S.Just   8000) = 0x01
256 encodeSamplingRate (S.Just   9600) = 0x02
257 encodeSamplingRate (S.Just  11025) = 0x03
258 encodeSamplingRate (S.Just  12000) = 0x04
259 encodeSamplingRate (S.Just  16000) = 0x05
260 encodeSamplingRate (S.Just  22050) = 0x06
261 encodeSamplingRate (S.Just  24000) = 0x07
262 encodeSamplingRate (S.Just  32000) = 0x08
263 encodeSamplingRate (S.Just  44100) = 0x09
264 encodeSamplingRate (S.Just  48000) = 0x0A
265 encodeSamplingRate (S.Just  64000) = 0x0B
266 encodeSamplingRate (S.Just  88200) = 0x0C
267 encodeSamplingRate (S.Just  96000) = 0x0D
268 encodeSamplingRate (S.Just 192000) = 0x0E
269 encodeSamplingRate               _ = 0x0F
270
271 decodeSamplingRate ∷ Word8 → S.Maybe Int
272 decodeSamplingRate 0x00 = S.Just   6000
273 decodeSamplingRate 0x01 = S.Just   8000
274 decodeSamplingRate 0x02 = S.Just   9600
275 decodeSamplingRate 0x03 = S.Just  11025
276 decodeSamplingRate 0x04 = S.Just  12000
277 decodeSamplingRate 0x05 = S.Just  16000
278 decodeSamplingRate 0x06 = S.Just  22025
279 decodeSamplingRate 0x07 = S.Just  24000
280 decodeSamplingRate 0x08 = S.Just  32000
281 decodeSamplingRate 0x09 = S.Just  44100
282 decodeSamplingRate 0x0A = S.Just  48000
283 decodeSamplingRate 0x0B = S.Just  64000
284 decodeSamplingRate 0x0C = S.Just  88200
285 decodeSamplingRate 0x0D = S.Just  96000
286 decodeSamplingRate 0x0E = S.Just 192000
287 decodeSamplingRate    _ =     S.Nothing
288
289 -- | Read WavPack blocks in a given stream lazily.
290 readBlocks ∷ L.ByteString → [Block]
291 readBlocks src
292     = case findNextBlock src of
293         (# S.Just block, src' #)
294             → block : readBlocks src'
295         (# S.Nothing, _ #)
296             → []
297
298 findNextBlock ∷ L.ByteString
299               → (# S.Maybe Block, L.ByteString #)
300 findNextBlock src
301     = case L.uncons src of
302         Nothing
303             → (# S.Nothing, L.empty #)
304
305         Just (119, _) -- 'w'
306             → tryGetBlock src
307
308         Just (_, src')
309             → findNextBlock src'
310
311 tryGetBlock ∷ L.ByteString → (# S.Maybe Block, L.ByteString #)
312 tryGetBlock src
313     = case L.splitAt 32 src of
314         (header, rest)
315             → case L.length header ≡ 32 of
316                  True
317                      → case L.take 4 header ≡ headerMagic of
318                           True
319                               -- Found the magic "wvpk". Let's parse
320                               -- the header and see if it's really a
321                               -- header we can accept.
322                               → case runGet get header of
323                                    bh → if isGoodHeader bh then
324                                              case getSubBlocksLazily rest $ bhSize bh of
325                                                (# subs, rest' #)
326                                                    → let !blk = Block {
327                                                                    blockHeader   = bh
328                                                                  , blockMetadata = subs
329                                                                  }
330                                                       in
331                                                         (# S.Just blk, rest' #)
332                                          else
333                                              findNextBlock $ L.tail src
334                           False
335                               → findNextBlock $ L.tail src
336                  False
337                      → (# S.Nothing, L.empty #)
338
339 headerMagic ∷ L.ByteString
340 headerMagic = L.pack [119, 118, 112, 107] -- "wvpk"
341
342 isGoodHeader ∷ BlockHeader → Bool
343 isGoodHeader bh
344     -- Rule #1: bhSize + 32 - 8 ≡ 0 (mod 2)
345     | odd $ bhSize bh               = False
346     -- Rule #2: bhSize + 32 - 8 ≤ 0x00100000
347     | bhSize bh + 32 - 8 > 0x100000 = False
348     -- Rule #3: bhSize + 32 - 8 > 24
349     | bhSize bh + 32 - 8 ≤ 24      = False
350     -- Rule #4: 0x402 ≤ bhVersion ≤ 0x410
351     | bhVersion bh < 0x402          = False
352     | bhVersion bh > 0x410          = False
353     -- Rule #5: bhBlockSamples < 0x00030000
354     | bhBlockSamples bh ≥ 0x30000  = False
355     -- Now it passed all the tests...
356     | otherwise                     = True