readBlocks

[wavpack.git] / Codec / Audio / WavPack / Block.hs

diff --git a/Codec/Audio/WavPack/Block.hs b/Codec/Audio/WavPack/Block.hs
index 8b532ade781c83743856b3425ae1acf35e874451..4ecdb7d8d40e5530f6e8e8846d8ef776320a104a 100644 (file)
--- a/Codec/Audio/WavPack/Block.hs
+++ b/Codec/Audio/WavPack/Block.hs
@@ -9,7 +9,7 @@ module Codec.Audio.WavPack.Block
     , BlockHeader(..)
     , BlockFlags(..)
 
-    , findNextBlock
+    , readBlocks
     )
     where
 import Codec.Audio.WavPack.Metadata
@@ -17,8 +17,8 @@ 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
@@ -44,8 +44,11 @@ instance Binary Block where
                         , blockMetadata = subs
                         }
 
-getSubBlocks ∷ Word32 → Get [SubBlock]
-getSubBlocks 0  = return []
+-- 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
@@ -53,6 +56,21 @@ getSubBlocks !blockSize
          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 {
@@ -268,10 +286,17 @@ decodeSamplingRate 0x0D = S.Just  96000
 decodeSamplingRate 0x0E = S.Just 192000
 decodeSamplingRate    _ =     S.Nothing
 
--- | Find a WavPack block in a given stream. Returns 'S.Nothing' if no
--- blocks are found.
-findNextBlock ∷ L.ByteString -- ^ the input
-              → (# S.Maybe Block, L.ByteString #) -- ^ the rest of input
+-- | 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
@@ -296,8 +321,8 @@ tryGetBlock src
                               -- header we can accept.
                               → case runGet get header of
                                    bh → if isGoodHeader bh then
-                                             case runGetState (getSubBlocks $ bhSize bh) rest 0 of
-                                               (subs, rest', _)
+                                             case getSubBlocksLazily rest $ bhSize bh of
+                                               (# subs, rest' #)
                                                    → let !blk = Block {
                                                                    blockHeader   = bh
                                                                  , blockMetadata = subs