]> gitweb @ CieloNegro.org - wavpack.git/blob - Codec/Audio/WavPack/Metadata.hs
601d42e666b8d45b2e68be9b28b9424af5feafec
[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     , DecorrTerms(..)
13     , RIFFHeader(..)
14     , RIFFTrailer(..)
15     , Unknown(..)
16     )
17     where
18 import Control.Monad
19 import Data.Binary
20 import Data.Binary.Get
21 import Data.Binary.Put
22 import Data.Bits
23 import qualified Data.ByteString.Lazy as L
24 import Data.Int
25 import Data.Typeable
26 import qualified Data.Vector.Unboxed as UV
27 import Prelude.Unicode
28
29 -- | Type class for every metadata sub-blocks.
30 class (Binary α, Eq α, Show α, Typeable α) ⇒ Metadata α where
31     -- | Get the metadata ID without odd-size bit nor large-block bit
32     -- (mandatory).
33     metaID   ∷ α → Word8
34     -- | Get the size of metadata, excluding the metadata header
35     -- (optional).
36     metaSize ∷ α → Word32
37     metaSize = fromIntegral ∘ L.length ∘ runPut ∘ put
38     -- | Cast a 'SubBlock' to this type of metadata (optional).
39     fromSubBlock ∷ SubBlock → Maybe α
40     fromSubBlock (SubBlock a) = cast a
41     -- | Wrap the metadata into 'SubBlock' (optional).
42     toSubBlock ∷ α → SubBlock
43     toSubBlock = SubBlock
44
45 -- | An opaque sub-block container.
46 data SubBlock = ∀α. Metadata α ⇒ SubBlock α
47                 deriving Typeable
48
49 instance Metadata SubBlock where
50     metaID   (SubBlock a) = metaID a
51     metaSize (SubBlock a) = metaSize a
52     fromSubBlock = Just
53     toSubBlock   = id
54
55 instance Binary SubBlock where
56     put (SubBlock a)
57         = let size     = metaSize a
58               size'    = size + 1
59               oddBit   = if odd size     then 0x40 else 0
60               largeBit = if size > 0x1FE then 0x80 else 0
61               idWord   = metaID a .|. oddBit .|. largeBit
62           in
63             do putWord8 idWord
64                if size > 0x1FE then
65                    -- Don't forget about the endianness.
66                    do putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
67                       putWord8 $ fromIntegral $ (size' `shiftR`  9) .&. 0xFF
68                       putWord8 $ fromIntegral $ (size' `shiftR` 17) .&. 0xFF
69                  else
70                       putWord8 $ fromIntegral $ (size' `shiftR`  1) .&. 0xFF
71                put a
72                when (odd size) $ putWord8 0
73
74     get = do idWord ← getWord8
75              let isOdd   = idWord .&. 0x40 ≢ 0
76                  isLarge = idWord .&. 0x80 ≢ 0
77                  rawID   = idWord .&. (complement 0x40) .&. (complement 0x80)
78                  adj     = if isOdd then -1 else 0
79              size ← if isLarge then
80                          do sz0 ← getWord8
81                             sz1 ← getWord8
82                             sz2 ← getWord8
83                             return $ ( (fromIntegral sz2 `shiftL` 17) .|.
84                                        (fromIntegral sz1 `shiftL`  9) .|.
85                                        (fromIntegral sz0 `shiftL`  1)
86                                      ) + adj
87                      else
88                          fmap ((+ adj) ∘ (`shiftL` 1) ∘ fromIntegral) getWord8
89              subb ← getLazyByteString $ fromIntegral (size ∷ Word32)
90              return $ runGet (getSubBlock rawID) subb
91         where
92           getSubBlock ∷ Word8 → Get SubBlock
93           getSubBlock 0x00 = fmap SubBlock (get ∷ Get Dummy      )
94           getSubBlock 0x02 = fmap SubBlock (get ∷ Get DecorrTerms)
95           getSubBlock 0x21 = fmap SubBlock (get ∷ Get RIFFHeader )
96           getSubBlock 0x22 = fmap SubBlock (get ∷ Get RIFFTrailer)
97           getSubBlock unknownID
98               = if unknownID .&. 0x20 ≡ 0 then
99                     fail ("Unknown WavPack metadata ID: " ⧺ show unknownID)
100                 else
101                     -- It's unknown but optional. We can safely ignore it.
102                     fmap (SubBlock ∘ Unknown unknownID) getRemainingLazyByteString
103
104 instance Eq SubBlock where
105     (SubBlock a) == (SubBlock b)
106         = Just a ≡ cast b
107
108 instance Show SubBlock where
109     show (SubBlock a) = show a
110
111 -- | Dummy metadata to pad WavPack blocks.
112 data Dummy
113     = Dummy {
114         -- | Must be less than 2^25 bytes long due to the limitation
115         -- of WavPack specification.
116         dumSize ∷ Word32
117       }
118     deriving (Eq, Show, Typeable)
119
120 instance Metadata Dummy where
121     metaID _ = 0x00
122     metaSize = dumSize
123
124 instance Binary Dummy where
125     put = putLazyByteString ∘ flip L.replicate 0x00 ∘ fromIntegral ∘ dumSize
126     get = fmap (Dummy ∘ fromIntegral) remaining
127
128 -- | Decorrelation terms and deltas.
129 data DecorrTerms
130     = DecorrTerms {
131         -- | [ (term, delta) ]
132         dectVec ∷ !(UV.Vector (Int8, Int8))
133       }
134     deriving (Eq, Show, Typeable)
135
136 instance Metadata DecorrTerms where
137     metaID _ = 0x02
138     metaSize = fromIntegral ∘ UV.length ∘ dectVec
139
140 instance Binary DecorrTerms where
141     put = UV.mapM_ (putWord8 ∘ packDT) ∘ dectVec
142         where
143           packDT ∷ (Int8, Int8) → Word8
144           packDT (term, δ)
145               = fromIntegral ( (term + 5 .&. 0x1F)
146                                .|.
147                                ((δ `shiftL` 5) .&. 0xE0)
148                              )
149
150     get = do n   ← remaining
151              vec ← UV.replicateM (fromIntegral n) $ fmap unpackDT getWord8
152              -- THINKME: unpack.c(read_decorr_terms) reverses the
153              -- order only when they are decoding. I don't know why so
154              -- I leave it unreversed for now.
155              return $ DecorrTerms vec
156         where
157           unpackDT ∷ Word8 → (Int8, Int8)
158           unpackDT w
159               = let term = (fromIntegral $ w .&. 0x1F) - 5
160                     δ    = fromIntegral $ (w `shiftR` 5) .&. 0x07
161                 in
162                   (term, δ)
163
164 -- | RIFF header for .wav files (before audio)
165 data RIFFHeader
166     = RIFFHeader {
167         riffHeader ∷ L.ByteString
168       }
169     deriving (Eq, Show, Typeable)
170
171 instance Metadata RIFFHeader where
172     metaID _ = 0x21
173
174 instance Binary RIFFHeader where
175     put = putLazyByteString ∘ riffHeader
176     get = fmap RIFFHeader getRemainingLazyByteString
177
178 -- | RIFF trailer for .wav files (after audio)
179 data RIFFTrailer
180     = RIFFTrailer {
181         riffTrailer ∷ L.ByteString
182       }
183     deriving (Eq, Show, Typeable)
184
185 instance Metadata RIFFTrailer where
186     metaID _ = 0x22
187
188 instance Binary RIFFTrailer where
189     put = putLazyByteString ∘ riffTrailer
190     get = fmap RIFFTrailer getRemainingLazyByteString
191
192 -- | Unknown but optional metadata found in the WavPack block.
193 data Unknown
194     = Unknown {
195         -- | The ID of this unknown metadata without odd-size bit nor
196         -- large-block bit.
197         unkID   ∷ Word8
198         -- | Raw data; must be less than 2^25 bytes long.
199       , unkData ∷ L.ByteString
200       }
201     deriving (Eq, Show, Typeable)
202
203 instance Metadata Unknown where
204     metaID   = unkID
205
206 instance Binary Unknown where
207     put = putLazyByteString ∘ unkData
208     get = error "unsupported operation"