findNextBlock

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

diff --git a/Codec/Audio/WavPack/Metadata.hs b/Codec/Audio/WavPack/Metadata.hs
index 4f98703baffc4bbf3a54981a0cbc64f6b469eac4..77901f445aedf505ab7e4ce117ae026ebdd147c7 100644 (file)
--- a/Codec/Audio/WavPack/Metadata.hs
+++ b/Codec/Audio/WavPack/Metadata.hs
@@ -1,44 +1,137 @@
 {-# LANGUAGE
-    ExistentialQuantification
+    DeriveDataTypeable
+  , ExistentialQuantification
   , UnicodeSyntax
   #-}
 -- | WavPack metadata sub-blocks
 module Codec.Audio.WavPack.Metadata
     ( Metadata(..)
-    , SomeMetadata(..)
+    , SubBlock
+
+    , Dummy(..)
+    , Unknown(..)
     )
     where
+import Control.Monad
 import Data.Binary
+import Data.Binary.Get
 import Data.Binary.Put
 import Data.Bits
 import qualified Data.ByteString.Lazy as L
 import Data.Typeable
 import Prelude.Unicode
 
+-- | Type class for every metadata sub-blocks.
 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
+    -- | Get the metadata ID without odd-size bit nor large-block bit
+    -- (mandatory).
     metaID   ∷ α → Word8
+    -- | Get the size of metadata, excluding the metadata header
+    -- (optional).
     metaSize ∷ α → Word32
-
     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
+    -- | Cast a 'SubBlock' to this type of metadata (optional).
+    fromSubBlock ∷ SubBlock → Maybe α
+    fromSubBlock (SubBlock a) = cast a
+    -- | Wrap the metadata into 'SubBlock' (optional).
+    toSubBlock ∷ α → SubBlock
+    toSubBlock = SubBlock
+
+-- | An opaque sub-block container.
+data SubBlock = ∀α. Metadata α ⇒ SubBlock α
+                deriving Typeable
 
-data SomeMetadata = ∀α. Metadata α ⇒ SomeMetadata α
+instance Metadata SubBlock where
+    metaID   (SubBlock a) = metaID a
+    metaSize (SubBlock a) = metaSize a
+    fromSubBlock = Just
+    toSubBlock   = id
 
-instance Binary SomeMetadata where
-    put (SomeMetadata a)
+instance Binary SubBlock where
+    put (SubBlock a)
         = let size     = metaSize a
-              oddBit   = if odd size   then 0x40 else 0
-              largeBit = if size > 255 then 0x80 else 0
+              size'    = size + 1
+              oddBit   = if odd size     then 0x40 else 0
+              largeBit = if size > 0x1FE then 0x80 else 0
               idWord   = metaID a .|. oddBit .|. largeBit
           in
             do putWord8 idWord
-               fail "FIXME"
+               if size > 0x1FE then
+                   -- Don't forget about the endianness.
+                   do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
+                      putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
+                      putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
+                 else
+                      putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
+               put a
+               when (odd size) $ putWord8 0
 
-    get = fail "FIXME"
+    get = do idWord ← getWord8
+             let isOdd   = idWord .&. 0x40 ≢ 0
+                 isLarge = idWord .&. 0x80 ≢ 0
+                 rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
+                 adj     = if isOdd then -1 else 0
+             size ← if isLarge then
+                         do sz0 ← getWord8
+                            sz1 ← getWord8
+                            sz2 ← getWord8
+                            return $ ( (fromIntegral sz2 `shiftL` 17) .|.
+                                       (fromIntegral sz1 `shiftL`  9) .|.
+                                       (fromIntegral sz0 `shiftL`  1)
+                                     ) + adj
+                     else
+                         fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
+             subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
+             return $ runGet (getSubBlock rawID) subb
+        where
+          getSubBlock ∷ Word8 → Get SubBlock
+          getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy)
+          getSubBlock unknownID
+              = if unknownID .&. 0x20 ≡ 0 then
+                    fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
+                else
+                    -- It's unknown but optional. We can safely ignore it.
+                    fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
 
-instance Eq SomeMetadata where
-    (SomeMetadata a) == (SomeMetadata b)
+instance Eq SubBlock where
+    (SubBlock a) == (SubBlock b)
         = Just a ≡ cast b
 
-instance Show SomeMetadata where
-    show (SomeMetadata a)
-        = show a
+instance Show SubBlock where
+    show (SubBlock a) = show a
+
+-- | Dummy metadata to pad WavPack blocks.
+data Dummy
+    = Dummy {
+        -- | Must be less than 2^25 bytes long due to the limitation
+        -- of WavPack specification.
+        dumSize ∷ Word32
+      }
+    deriving (Eq, Show, Typeable)
+
+instance Metadata Dummy where
+    metaID _ = 0x00
+    metaSize = dumSize
+
+instance Binary Dummy where
+    put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
+    get = fmap (Dummy ∘ fromIntegral) remaining
+
+-- | Unknown but optional metadata found in the WavPack block.
+data Unknown
+    = Unknown {
+        -- | The ID of this unknown metadata without odd-size bit nor
+        -- large-block bit.
+        unkID   ∷ Word8
+        -- | Raw data; must be less than 2^25 bytes long.
+      , unkData ∷ L.ByteString
+      }
+    deriving (Eq, Show, Typeable)
+
+instance Metadata Unknown where
+    metaID   = unkID
+    metaSize = fromIntegral ∘ L.length ∘ unkData
+
+instance Binary Unknown where
+    put = putLazyByteString ∘ unkData
+    get = (⊥)