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