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