- let Right bf
- = runBitGet (S.reverse bs) $
- do BG.skip 1 -- reserved
- falseStereo ← getBit
- iirShaping ← getBit
- BG.skip 2 -- reserved
- samplingRate ← getAsWord8 4
- maxMagnitude ← getAsWord8 5
- leftShift ← getAsWord8 5
- finalBlock ← getBit
- initialBlock ← getBit
- hybridBalance ← getBit
- hybridBitrate ← getBit
- extendedInt ← getBit
- floatData ← getBit
- hybridShape ← getBit
- crossDecorr ← getBit
- jointStereo ← getBit
- hybrid ← getBit
- mono ← getBit
- bytesPerSample ← getAsWord8 2
- return BlockFlags {
- bfBytesPerSample = bytesPerSample + 1
- , bfMono = mono
- , bfHybrid = hybrid
- , bfJointStereo = jointStereo
- , bfCrossDecorr = crossDecorr
- , bfHybridShape = hybridShape
- , bfFloatData = floatData
- , bfExtendedInt = extendedInt
- , bfHybridBitrate = hybridBitrate
- , bfHybridBalance = hybridBalance
- , bfInitialBlock = initialBlock
- , bfFinalBlock = finalBlock
- , bfLeftShift = leftShift
- , bfMaxMagnitude = maxMagnitude
- , bfSamplingRate = samplingRate
- , bfIIRShaping = iirShaping
- , bfFalseStereo = falseStereo
- }
- return bf
+ let !r = runBitGet (S.reverse bs) $
+ do BG.skip 1 -- reserved
+ falseStereo ← getBit
+ iirShaping ← getBit
+ BG.skip 2 -- reserved
+ samplingRate ← getAsWord8 4
+ maxMagnitude ← getAsWord8 5
+ leftShift ← getAsWord8 5
+ finalBlock ← getBit
+ initialBlock ← getBit
+ hybridBalance ← getBit
+ hybridBitrate ← getBit
+ extendedInt ← getBit
+ floatData ← getBit
+ hybridShape ← getBit
+ crossDecorr ← getBit
+ jointStereo ← getBit
+ hybrid ← getBit
+ mono ← getBit
+ bytesPerSample ← getAsWord8 2
+ return $! BlockFlags {
+ bfBytesPerSample = bytesPerSample + 1
+ , bfMono = mono
+ , bfHybrid = hybrid
+ , bfJointStereo = jointStereo
+ , bfCrossDecorr = crossDecorr
+ , bfHybridShape = hybridShape
+ , bfFloatData = floatData
+ , bfExtendedInt = extendedInt
+ , bfHybridBitrate = hybridBitrate
+ , bfHybridBalance = hybridBalance
+ , bfInitialBlock = initialBlock
+ , bfFinalBlock = finalBlock
+ , bfLeftShift = leftShift
+ , bfMaxMagnitude = maxMagnitude
+ , bfSamplingRate = decodeSamplingRate samplingRate
+ , bfIIRShaping = iirShaping
+ , bfFalseStereo = falseStereo
+ }
+ case r of
+ Left err → fail err
+ Right bf → return $! bf
+
+encodeSamplingRate ∷ S.Maybe Int → Word8
+encodeSamplingRate (S.Just 6000) = 0x00
+encodeSamplingRate (S.Just 8000) = 0x01
+encodeSamplingRate (S.Just 9600) = 0x02
+encodeSamplingRate (S.Just 11025) = 0x03
+encodeSamplingRate (S.Just 12000) = 0x04
+encodeSamplingRate (S.Just 16000) = 0x05
+encodeSamplingRate (S.Just 22050) = 0x06
+encodeSamplingRate (S.Just 24000) = 0x07
+encodeSamplingRate (S.Just 32000) = 0x08
+encodeSamplingRate (S.Just 44100) = 0x09
+encodeSamplingRate (S.Just 48000) = 0x0A
+encodeSamplingRate (S.Just 64000) = 0x0B
+encodeSamplingRate (S.Just 88200) = 0x0C
+encodeSamplingRate (S.Just 96000) = 0x0D
+encodeSamplingRate (S.Just 192000) = 0x0E
+encodeSamplingRate _ = 0x0F
+
+decodeSamplingRate ∷ Word8 → S.Maybe Int
+decodeSamplingRate 0x00 = S.Just 6000
+decodeSamplingRate 0x01 = S.Just 8000
+decodeSamplingRate 0x02 = S.Just 9600
+decodeSamplingRate 0x03 = S.Just 11025
+decodeSamplingRate 0x04 = S.Just 12000
+decodeSamplingRate 0x05 = S.Just 16000
+decodeSamplingRate 0x06 = S.Just 22025
+decodeSamplingRate 0x07 = S.Just 24000
+decodeSamplingRate 0x08 = S.Just 32000
+decodeSamplingRate 0x09 = S.Just 44100
+decodeSamplingRate 0x0A = S.Just 48000
+decodeSamplingRate 0x0B = S.Just 64000
+decodeSamplingRate 0x0C = S.Just 88200
+decodeSamplingRate 0x0D = S.Just 96000
+decodeSamplingRate 0x0E = S.Just 192000
+decodeSamplingRate _ = S.Nothing
+
+-- | Read WavPack blocks in a given stream lazily.
+readBlocks ∷ L.ByteString → [Block]
+readBlocks src
+ = case findNextBlock src of
+ (# S.Just block, src' #)
+ → block : readBlocks src'
+ (# S.Nothing, _ #)
+ → []
+
+findNextBlock ∷ L.ByteString
+ → (# S.Maybe Block, L.ByteString #)
+findNextBlock src
+ = case L.uncons src of
+ Nothing
+ → (# S.Nothing, L.empty #)
+
+ Just (119, _) -- 'w'
+ → tryGetBlock src
+
+ Just (_, src')
+ → findNextBlock src'
+
+tryGetBlock ∷ L.ByteString → (# S.Maybe Block, L.ByteString #)
+tryGetBlock src
+ = case L.splitAt 32 src of
+ (header, rest)
+ → case L.length header ≡ 32 of
+ True
+ → case L.take 4 header ≡ headerMagic of
+ True
+ -- Found the magic "wvpk". Let's parse
+ -- the header and see if it's really a
+ -- header we can accept.
+ → case runGet get header of
+ bh → if isGoodHeader bh then
+ case getSubBlocksLazily rest $ bhSize bh of
+ (# subs, rest' #)
+ → let !blk = Block {
+ blockHeader = bh
+ , blockMetadata = subs
+ }
+ in
+ (# S.Just blk, rest' #)
+ else
+ findNextBlock $ L.tail src
+ False
+ → findNextBlock $ L.tail src
+ False
+ → (# S.Nothing, L.empty #)
+
+headerMagic ∷ L.ByteString
+headerMagic = L.pack [119, 118, 112, 107] -- "wvpk"
+
+isGoodHeader ∷ BlockHeader → Bool
+isGoodHeader bh
+ -- Rule #1: bhSize + 32 - 8 ≡ 0 (mod 2)
+ | odd $ bhSize bh = False
+ -- Rule #2: bhSize + 32 - 8 ≤ 0x00100000
+ | bhSize bh + 32 - 8 > 0x100000 = False
+ -- Rule #3: bhSize + 32 - 8 > 24
+ | bhSize bh + 32 - 8 ≤ 24 = False
+ -- Rule #4: 0x402 ≤ bhVersion ≤ 0x410
+ | bhVersion bh < 0x402 = False
+ | bhVersion bh > 0x410 = False
+ -- Rule #5: bhBlockSamples < 0x00030000
+ | bhBlockSamples bh ≥ 0x30000 = False
+ -- Now it passed all the tests...
+ | otherwise = True