1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
|
{-# Language FlexibleInstances #-}
{-# Language IncoherentInstances #-}
{-# Language OverlappingInstances #-}
{-# Language TypeSynonymInstances #-}
--------------------------------------------------------------------
-- |
-- Module : Data.MessagePack.Pack
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
-- License : BSD3
--
-- Maintainer: tanaka.hideyuki@gmail.com
-- Stability : experimental
-- Portability: portable
--
-- MessagePack Serializer using @Data.Binary.Pack@
--
--------------------------------------------------------------------
module Data.MessagePack.Pack (
-- * Serializable class
Packable(..),
-- * Simple function to pack a Haskell value
pack,
) where
import Data.Binary.Put
import Data.Binary.IEEE754
import Data.Bits
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as L
import qualified Data.Vector as V
-- | Serializable class
class Packable a where
-- | Serialize a value
put :: a -> Put
-- | Pack Haskell data to MessagePack string.
pack :: Packable a => a -> L.ByteString
pack = runPut . put
instance Packable Int where
put n =
case n of
_ | n >= 0 && n <= 127 ->
putWord8 $ fromIntegral n
_ | n >= -32 && n <= -1 ->
putWord8 $ fromIntegral n
_ | n >= 0 && n < 0x100 -> do
putWord8 0xCC
putWord8 $ fromIntegral n
_ | n >= 0 && n < 0x10000 -> do
putWord8 0xCD
putWord16be $ fromIntegral n
_ | n >= 0 && n < 0x100000000 -> do
putWord8 0xCE
putWord32be $ fromIntegral n
_ | n >= 0 -> do
putWord8 0xCF
putWord64be $ fromIntegral n
_ | n >= -0x80 -> do
putWord8 0xD0
putWord8 $ fromIntegral n
_ | n >= -0x8000 -> do
putWord8 0xD1
putWord16be $ fromIntegral n
_ | n >= -0x80000000 -> do
putWord8 0xD2
putWord32be $ fromIntegral n
_ -> do
putWord8 0xD3
putWord64be $ fromIntegral n
instance Packable () where
put _ =
putWord8 0xC0
instance Packable Bool where
put True = putWord8 0xC3
put False = putWord8 0xC2
instance Packable Double where
put d = do
putWord8 0xCB
putFloat64be d
instance Packable String where
put = putString length (putByteString . B8.pack)
instance Packable B.ByteString where
put = putString B.length putByteString
instance Packable L.ByteString where
put = putString (fromIntegral . L.length) putLazyByteString
putString :: (s -> Int) -> (s -> Put) -> s -> Put
putString lf pf str = do
case lf str of
len | len <= 31 -> do
putWord8 $ 0xA0 .|. fromIntegral len
len | len < 0x10000 -> do
putWord8 0xDA
putWord16be $ fromIntegral len
len -> do
putWord8 0xDB
putWord32be $ fromIntegral len
pf str
instance Packable a => Packable [a] where
put = putArray length (mapM_ put)
instance Packable a => Packable (V.Vector a) where
put = putArray V.length (V.mapM_ put)
instance (Packable a1, Packable a2) => Packable (a1, a2) where
put = putArray (const 2) f where
f (a1, a2) = put a1 >> put a2
instance (Packable a1, Packable a2, Packable a3) => Packable (a1, a2, a3) where
put = putArray (const 3) f where
f (a1, a2, a3) = put a1 >> put a2 >> put a3
instance (Packable a1, Packable a2, Packable a3, Packable a4) => Packable (a1, a2, a3, a4) where
put = putArray (const 4) f where
f (a1, a2, a3, a4) = put a1 >> put a2 >> put a3 >> put a4
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5) => Packable (a1, a2, a3, a4, a5) where
put = putArray (const 5) f where
f (a1, a2, a3, a4, a5) = put a1 >> put a2 >> put a3 >> put a4 >> put a5
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6) => Packable (a1, a2, a3, a4, a5, a6) where
put = putArray (const 6) f where
f (a1, a2, a3, a4, a5, a6) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7) => Packable (a1, a2, a3, a4, a5, a6, a7) where
put = putArray (const 7) f where
f (a1, a2, a3, a4, a5, a6, a7) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8) => Packable (a1, a2, a3, a4, a5, a6, a7, a8) where
put = putArray (const 8) f where
f (a1, a2, a3, a4, a5, a6, a7, a8) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8
instance (Packable a1, Packable a2, Packable a3, Packable a4, Packable a5, Packable a6, Packable a7, Packable a8, Packable a9) => Packable (a1, a2, a3, a4, a5, a6, a7, a8, a9) where
put = putArray (const 9) f where
f (a1, a2, a3, a4, a5, a6, a7, a8, a9) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 >> put a7 >> put a8 >> put a9
putArray :: (a -> Int) -> (a -> Put) -> a -> Put
putArray lf pf arr = do
case lf arr of
len | len <= 15 ->
putWord8 $ 0x90 .|. fromIntegral len
len | len < 0x10000 -> do
putWord8 0xDC
putWord16be $ fromIntegral len
len -> do
putWord8 0xDD
putWord32be $ fromIntegral len
pf arr
instance (Packable k, Packable v) => Packable [(k, v)] where
put = putMap length (mapM_ putPair)
instance (Packable k, Packable v) => Packable (V.Vector (k, v)) where
put = putMap V.length (V.mapM_ putPair)
putPair :: (Packable a, Packable b) => (a, b) -> Put
putPair (a, b) = put a >> put b
putMap :: (a -> Int) -> (a -> Put) -> a -> Put
putMap lf pf m = do
case lf m of
len | len <= 15 ->
putWord8 $ 0x80 .|. fromIntegral len
len | len < 0x10000 -> do
putWord8 0xDE
putWord16be $ fromIntegral len
len -> do
putWord8 0xDF
putWord32be $ fromIntegral len
pf m
instance Packable a => Packable (Maybe a) where
put Nothing = put ()
put (Just a) = put a
|
