sub-block preambles

diff --git a/Codec/Audio/WavPack/Metadata.hs b/Codec/Audio/WavPack/Metadata.hs
index 4f98703baffc4bbf3a54981a0cbc64f6b469eac4..0b8d3ebbb060f6bbdd9ea269fabf19fe401a1d61 100644 (file)
--- a/Codec/Audio/WavPack/Metadata.hs
+++ b/Codec/Audio/WavPack/Metadata.hs
@@ -1,14 +1,20 @@
 {-# 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
@@ -21,24 +27,87 @@ class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
 
     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
 
-data SomeMetadata = ∀α. Metadata α ⇒ SomeMetadata α
+data SubBlock = ∀α. Metadata α ⇒ SubBlock α
 
-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
               idWord   = metaID a .|. oddBit .|. largeBit
           in
             do putWord8 idWord
-               fail "FIXME"
+               if size > 255 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 {
+        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 {
+        unkID   ∷ !Word8
+      , 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 = (⊥)