X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=wavpack.git;a=blobdiff_plain;f=Codec%2FAudio%2FWavPack%2FBlock.hs;h=4ecdb7d8d40e5530f6e8e8846d8ef776320a104a;hp=db527064654a261705ac8a2e458323ecdf138943;hb=98a1dd78c7bb73c5d66f4773b63bbc5b94e7e618;hpb=e5feea5a7fd246c6a2bd47ff86beecd48d7b9040 diff --git a/Codec/Audio/WavPack/Block.hs b/Codec/Audio/WavPack/Block.hs index db52706..4ecdb7d 100644 --- a/Codec/Audio/WavPack/Block.hs +++ b/Codec/Audio/WavPack/Block.hs @@ -1,24 +1,76 @@ {-# LANGUAGE - UnicodeSyntax + BangPatterns + , UnboxedTuples + , UnicodeSyntax #-} --- | Data types for WavPack codec. +-- | WavPack blocks module Codec.Audio.WavPack.Block - ( BlockHeader(..) + ( Block(..) + , BlockHeader(..) , BlockFlags(..) - , findNextHeader + , 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 qualified Data.Binary.Strict.BitGet as BG 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 { @@ -72,7 +124,7 @@ instance Binary BlockHeader where blockSamples ← getWord32le flags ← get crc ← getWord32le - return BlockHeader { + return $! BlockHeader { bhSize = size + 8 - 32 , bhVersion = version , bhTrackNo = trackNo @@ -121,7 +173,7 @@ data BlockFlags -- require minus 1) , bfMaxMagnitude ∷ !Word8 -- | sampling rate ('Nothing' = unknown/custom) - , bfSamplingRate ∷ !(Maybe Int) + , bfSamplingRate ∷ !(S.Maybe Int) -- | 'True' = use IIR for negative hybrid noise shaping , bfIIRShaping ∷ !Bool -- | 'True' = false stereo (data is mono but output is stereo) @@ -131,134 +183,174 @@ data BlockFlags 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 + = 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 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 = decodeSamplingRate 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 -encodeSamplingRate ∷ Maybe Int → Word8 -encodeSamplingRate (Just 6000) = 0x00 -encodeSamplingRate (Just 8000) = 0x01 -encodeSamplingRate (Just 9600) = 0x02 -encodeSamplingRate (Just 11025) = 0x03 -encodeSamplingRate (Just 12000) = 0x04 -encodeSamplingRate (Just 16000) = 0x05 -encodeSamplingRate (Just 22050) = 0x06 -encodeSamplingRate (Just 24000) = 0x07 -encodeSamplingRate (Just 32000) = 0x08 -encodeSamplingRate (Just 44100) = 0x09 -encodeSamplingRate (Just 48000) = 0x0A -encodeSamplingRate (Just 64000) = 0x0B -encodeSamplingRate (Just 88200) = 0x0C -encodeSamplingRate (Just 96000) = 0x0D -encodeSamplingRate (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 -decodeSamplingRate ∷ Word8 → Maybe Int -decodeSamplingRate 0x00 = Just 6000 -decodeSamplingRate 0x01 = Just 8000 -decodeSamplingRate 0x02 = Just 9600 -decodeSamplingRate 0x03 = Just 11025 -decodeSamplingRate 0x04 = Just 12000 -decodeSamplingRate 0x05 = Just 16000 -decodeSamplingRate 0x06 = Just 22025 -decodeSamplingRate 0x07 = Just 24000 -decodeSamplingRate 0x08 = Just 32000 -decodeSamplingRate 0x09 = Just 44100 -decodeSamplingRate 0x0A = Just 48000 -decodeSamplingRate 0x0B = Just 64000 -decodeSamplingRate 0x0C = Just 88200 -decodeSamplingRate 0x0D = Just 96000 -decodeSamplingRate 0x0E = Just 192000 -decodeSamplingRate _ = 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, _ #) + → [] --- | Find a WavPack header in a given stream. Returns 'Nothing' if no --- headers are found. -findNextHeader ∷ L.ByteString -- ^ the input - → Maybe (BlockHeader, L.ByteString) -- ^ a header and the rest of input -findNextHeader src +findNextBlock ∷ L.ByteString + → (# S.Maybe Block, L.ByteString #) +findNextBlock src = case L.uncons src of Nothing - → Nothing - Just (119, src') -- 'w' - → let (header, rest) = L.splitAt 32 src - in - case L.length header ≡ 32 of - False - → Nothing - True - → let Just (magicW, header' ) = L.uncons header - Just (magicV, header'' ) = L.uncons header' - Just (magicP, header''') = L.uncons header'' - magicK = L.head header''' - in - if magicW ≡ 119 ∧ magicV ≡ 118 ∧ magicP ≡ 112 ∧ magicK ≡ 107 then - -- Found the magic 'wvpk'. - let bh = runGet get header - in - Just (bh, rest) - else - findNextHeader src' + → (# S.Nothing, L.empty #) + + Just (119, _) -- 'w' + → tryGetBlock src + Just (_, src') - → findNextHeader 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