{-# LANGUAGE BangPatterns , UnboxedTuples , UnicodeSyntax #-} -- | WavPack blocks module Codec.Audio.WavPack.Block ( Block(..) , BlockHeader(..) , BlockFlags(..) , readBlocks ) where import Codec.Audio.WavPack.Metadata import Data.Binary import Data.Binary.BitPut (putBit, putNBits, runBitPut) import Data.Binary.Get import Data.Binary.Put import Data.Binary.Strict.BitGet (getBit, getAsWord8, runBitGet) import qualified Data.Binary.Strict.BitGet as BG import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.Strict as S import Prelude.Unicode -- | The WavPack block. data Block = Block { blockHeader ∷ !BlockHeader , blockMetadata ∷ [SubBlock] } deriving (Show, Eq) instance Binary Block where put b = do put $ blockHeader b mapM_ put $ blockMetadata b get = do header ← get subs ← getSubBlocks (bhSize header) return $! Block { blockHeader = header , blockMetadata = subs } -- Be aware; the Get monad is like a strict State monad so the entire -- sub-blocks are parsed at once. This might not be what you want -- (like me). getSubBlocks ∷ Integral n ⇒ n → Get [SubBlock] getSubBlocks 0 = return $! [] getSubBlocks !blockSize = do before ← bytesRead meta ← get after ← bytesRead rest ← getSubBlocks $ blockSize - fromIntegral (after - before) return (meta : rest) -- The lazy version. getSubBlocksLazily ∷ Integral n ⇒ L.ByteString → n → (# [SubBlock], L.ByteString #) getSubBlocksLazily src 0 = (# [], src #) getSubBlocksLazily src !blockSize = let (sub, src', consumed) = runGetState get src 0 (# subs, src'' #) = getSubBlocksLazily src' $ blockSize - fromIntegral consumed in (# sub : subs, src'' #) -- | The preamble to every block in both the .wv and .wvc files. data BlockHeader = BlockHeader { -- | size of entire block (excluding the header) bhSize ∷ !Word32 -- | 0x402 to 0x410 are currently valid for decode , bhVersion ∷ !Word16 -- | track number (0 if not used, like now) , bhTrackNo ∷ !Word8 -- | track sub-index (0 if not used, like now) , bhIndexNo ∷ !Word8 -- | total samples for entire file, but this is only valid if -- 'bhBlockIndex' == 0 and a value of -1 indicates unknown -- length , bhTotalSamples ∷ !Word32 -- | index of first sample in block relative to beginning of -- file (normally this would start at 0 for the first block) , bhBlockIndex ∷ !Word32 -- | number of samples in this block (0 = no audio) , bhBlockSamples ∷ !Word32 -- | various flags for id and decoding , bhFlags ∷ !BlockFlags -- | crc for actual decoded data , bhCRC ∷ !Word32 } deriving (Show, Eq) instance Binary BlockHeader where put bh = do putWord8 119 -- 'w' putWord8 118 -- 'v' putWord8 112 -- 'p' putWord8 107 -- 'k' putWord32le $ bhSize bh + 32 - 8 putWord16le $ bhVersion bh putWord8 $ bhTrackNo bh putWord8 $ bhIndexNo bh putWord32le $ bhTotalSamples bh putWord32le $ bhBlockIndex bh putWord32le $ bhBlockSamples bh put $ bhFlags bh putWord32le $ bhCRC bh get = do skip 4 -- "wvpk" size ← getWord32le version ← getWord16le trackNo ← getWord8 indexNo ← getWord8 totalSamples ← getWord32le blockIndex ← getWord32le blockSamples ← getWord32le flags ← get crc ← getWord32le return $! BlockHeader { bhSize = size + 8 - 32 , bhVersion = version , bhTrackNo = trackNo , bhIndexNo = indexNo , bhTotalSamples = totalSamples , bhBlockIndex = blockIndex , bhBlockSamples = blockSamples , bhFlags = flags , bhCRC = crc } -- | Various flags for decoding blocks data BlockFlags = BlockFlags { -- | 1 <= n <= 4 bfBytesPerSample ∷ !Word8 -- | 'False' = stereo output; 'True' = mono output , bfMono ∷ !Bool -- | 'False' = lossless mode; 'True' = hybrid mode , bfHybrid ∷ !Bool -- | 'False' = true stereo; 'True' = joint stereo (mid/side) , bfJointStereo ∷ !Bool -- | 'False' = independent channels; 'True' = cross-channel -- decorrelation , bfCrossDecorr ∷ !Bool -- | 'False' = flat noise spectrum in hybrid; 'True' = hybrid -- noise shaping , bfHybridShape ∷ !Bool -- | 'False' = integer data; 'True' = floating point data , bfFloatData ∷ !Bool -- | 'True' = extended size integers (> 24-bit); 'False' = -- shifted integers , bfExtendedInt ∷ !Bool -- | 'False' = hybrid mode parameters control noise level; -- 'True' = hybrid mode parameters control bitrate , bfHybridBitrate ∷ !Bool -- | 'True' = hybrid noise balanced between channels , bfHybridBalance ∷ !Bool -- | 'True' = initial block in sequence (for multichannel) , bfInitialBlock ∷ !Bool -- | 'True' = final block in sequence (for multichannel) , bfFinalBlock ∷ !Bool -- | amount of data left-shift after decode (0-31 places) , bfLeftShift ∷ !Word8 -- | maximum magnitude of decoded data (number of bits integers -- require minus 1) , bfMaxMagnitude ∷ !Word8 -- | sampling rate ('Nothing' = unknown/custom) , bfSamplingRate ∷ !(S.Maybe Int) -- | 'True' = use IIR for negative hybrid noise shaping , bfIIRShaping ∷ !Bool -- | 'True' = false stereo (data is mono but output is stereo) , bfFalseStereo ∷ !Bool } deriving (Show, Eq) instance Binary BlockFlags where put bf = let !bs = runBitPut $ do putBit False -- reserved putBit $ bfFalseStereo bf putBit $ bfIIRShaping bf putNBits 2 (0 ∷ Word8) -- reserved putNBits 4 $ encodeSamplingRate $ bfSamplingRate bf putNBits 5 $ bfMaxMagnitude bf putNBits 5 $ bfLeftShift bf putBit $ bfFinalBlock bf putBit $ bfInitialBlock bf putBit $ bfHybridBalance bf putBit $ bfHybridBitrate bf putBit $ bfExtendedInt bf putBit $ bfFloatData bf putBit $ bfHybridShape bf putBit $ bfCrossDecorr bf putBit $ bfJointStereo bf putBit $ bfHybrid bf putBit $ bfMono bf putNBits 2 $! bfBytesPerSample bf - 1 in putLazyByteString (L.reverse bs) get = do bs ← getBytes 4 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