35864b1b46bc0c9911a6b9d4a04fa2c2e87a038e
[wavpack.git] / Codec / Audio / WavPack / Metadata.hs
1 {-# LANGUAGE
2     DeriveDataTypeable
3   , ExistentialQuantification
4   , UnicodeSyntax
5   #-}
6 -- | WavPack metadata sub-blocks
7 module Codec.Audio.WavPack.Metadata
8     ( Metadata(..)
9     , SubBlock
10
11     , Dummy(..)
12     , Unknown(..)
13     )
14     where
15 import Control.Monad
16 import Data.Binary
17 import Data.Binary.Get
18 import Data.Binary.Put
19 import Data.Bits
20 import qualified Data.ByteString.Lazy as L
21 import Data.Typeable
22 import Prelude.Unicode
23
24 -- | Type class for every metadata sub-blocks.
25 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
26     -- | Get the metadata ID without odd-size bit nor large-block bit
27     -- (mandatory).
28     metaID   ∷ α → Word8
29     -- | Get the size of metadata (optional).
30     metaSize ∷ α → Word32
31     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
32     -- | Cast a 'SubBlock' to this type of metadata (optional).
33     fromSubBlock ∷ SubBlock → Maybe α
34     fromSubBlock (SubBlock a) = cast a
35     -- | Wrap the metadata into 'SubBlock' (optional).
36     toSubBlock ∷ α → SubBlock
37     toSubBlock = SubBlock
38
39 -- | An opaque sub-block container.
40 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
41                 deriving Typeable
42
43 instance Metadata SubBlock where
44     metaID   (SubBlock a) = metaID a
45     metaSize (SubBlock a) = metaSize a
46     fromSubBlock = Just
47     toSubBlock   = id
48
49 instance Binary SubBlock where
50     put (SubBlock a)
51         = let size     = metaSize a
52               oddBit   = if odd size   then 0x40 else 0
53               largeBit = if size > 255 then 0x80 else 0
54               idWord   = metaID a .|. oddBit .|. largeBit
55           in
56             do putWord8 idWord
57                if size > 255 then
58                    -- Don't forget about the endianness.
59                    do putWord8 $ fromIntegral $ (size `shiftR`  1) .&. 0xFF
60                       putWord8 $ fromIntegral $ (size `shiftR`  9) .&. 0xFF
61                       putWord8 $ fromIntegral $ (size `shiftR` 17) .&. 0xFF
62                  else
63                       putWord8 $ fromIntegral $ (size `shiftR`  1) .&. 0xFF
64                put a
65                when (odd size) $ putWord8 0
66
67     get = do idWord ← getWord8
68              let isOdd   = idWord .&. 0x40 ≢ 0
69                  isLarge = idWord .&. 0x80 ≢ 0
70                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
71                  adj     = if isOdd then -1 else 0
72              size ← if isLarge then
73                          do sz0 ← getWord8
74                             sz1 ← getWord8
75                             sz2 ← getWord8
76                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
77                                        (fromIntegral sz1 `shiftL`  9) .|.
78                                        (fromIntegral sz0 `shiftL`  1)
79                                      ) + adj
80                      else
81                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
82              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
83              return $ runGet (getSubBlock rawID) subb
84         where
85           getSubBlock ∷ Word8 → Get SubBlock
86           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy)
87           getSubBlock unknownID
88               = if unknownID .&. 0x20 ≡ 0 then
89                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
90                 else
91                     -- It's unknown but optional. We can safely ignore it.
92                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
93
94 instance Eq SubBlock where
95     (SubBlock a) == (SubBlock b)
96         = Just a ≡ cast b
97
98 instance Show SubBlock where
99     show (SubBlock a) = show a
100
101 -- | Dummy metadata to pad WavPack blocks.
102 data Dummy
103     = Dummy {
104         -- | Must be less than 2^25 bytes long due to the limitation
105         -- of WavPack specification.
106         dumSize ∷ Word32
107       }
108     deriving (Eq, Show, Typeable)
109
110 instance Metadata Dummy where
111     metaID _ = 0x00
112     metaSize = dumSize
113
114 instance Binary Dummy where
115     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
116     get = fmap (Dummy ∘ fromIntegral) remaining
117
118 -- | Unknown but optional metadata found in the WavPack block.
119 data Unknown
120     = Unknown {
121         -- | The ID of this unknown metadata.
122         unkID   ∷ Word8
123         -- | Raw data; must be less than 2^25 bytes long.
124       , unkData ∷ L.ByteString
125       }
126     deriving (Eq, Show, Typeable)
127
128 instance Metadata Unknown where
129     metaID   = unkID
130     metaSize = fromIntegral ∘ L.length ∘ unkData
131
132 instance Binary Unknown where
133     put = putLazyByteString ∘ unkData
134     get = (⊥)