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
187
188
|
--
-- (c) The University of Glasgow 2002-2006
--
-- Serialized values
{-# LANGUAGE ScopedTypeVariables #-}
module Serialized (
-- * Main Serialized data type
Serialized,
seqSerialized,
-- * Going into and out of 'Serialized'
toSerialized, fromSerialized,
-- * Handy serialization functions
serializeWithData, deserializeWithData,
) where
import Binary
import Outputable
import FastString
import Util
import Data.Bits
import Data.Word ( Word8 )
import Data.Data
-- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
data Serialized = Serialized TypeRep [Word8]
instance Outputable Serialized where
ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type)
instance Binary Serialized where
put_ bh (Serialized the_type bytes) = do
put_ bh the_type
put_ bh bytes
get bh = do
the_type <- get bh
bytes <- get bh
return (Serialized the_type bytes)
-- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized
toSerialized serialize what = Serialized (typeOf what) (serialize what)
-- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
-- Otherwise return @Nothing@.
fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized deserialize (Serialized the_type bytes)
| the_type == typeOf (undefined :: a) = Just (deserialize bytes)
| otherwise = Nothing
-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
seqSerialized :: Serialized -> ()
seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
-- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
serializeWithData :: Data a => a -> [Word8]
serializeWithData what = serializeWithData' what []
serializeWithData' :: Data a => a -> [Word8] -> [Word8]
serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
(\x -> (serializeConstr (constrRep (toConstr what)), x))
what
-- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
deserializeWithData :: Data a => [Word8] -> a
deserializeWithData = snd . deserializeWithData'
deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
(\x -> (bytes, x))
(repConstr (dataTypeOf (undefined :: a)) constr_rep)
serializeConstr :: ConstrRep -> [Word8] -> [Word8]
serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix
serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i
serializeConstr (FloatConstr r) = serializeWord8 3 . serializeRational r
serializeConstr (CharConstr c) = serializeWord8 4 . serializeChar c
deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
case constr_ix of
1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix)
2 -> deserializeInteger bytes $ \i -> k (IntConstr i)
3 -> deserializeRational bytes $ \r -> k (FloatConstr r)
4 -> deserializeChar bytes $ \c -> k (CharConstr c)
x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
#if __GLASGOW_HASKELL__ < 707
serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8]
serializeFixedWidthNum what = go (bitSize what) what
#else
serializeFixedWidthNum :: forall a. (Num a, Integral a, FiniteBits a) => a -> [Word8] -> [Word8]
serializeFixedWidthNum what = go (finiteBitSize what) what
#endif
where
go :: Int -> a -> [Word8] -> [Word8]
go size current rest
| size <= 0 = rest
| otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
#if __GLASGOW_HASKELL__ < 707
deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b
deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k
#else
deserializeFixedWidthNum :: forall a b. (Num a, Integral a, FiniteBits a) => [Word8] -> (a -> [Word8] -> b) -> b
deserializeFixedWidthNum bytes k = go (finiteBitSize (undefined :: a)) bytes k
#endif
where
go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
go size bytes k
| size <= 0 = k 0 bytes
| otherwise = case bytes of
(byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
[] -> error "deserializeFixedWidthNum: unexpected end of stream"
serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
serializeEnum = serializeInt . fromEnum
deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
deserializeEnum bytes k = deserializeInt bytes (k . toEnum)
serializeWord8 :: Word8 -> [Word8] -> [Word8]
serializeWord8 x = (x:)
deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
deserializeWord8 (byte:bytes) k = k byte bytes
deserializeWord8 [] _ = error "deserializeWord8: unexpected end of stream"
serializeInt :: Int -> [Word8] -> [Word8]
serializeInt = serializeFixedWidthNum
deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
deserializeInt = deserializeFixedWidthNum
serializeRational :: (Real a) => a -> [Word8] -> [Word8]
serializeRational = serializeString . show . toRational
deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b
deserializeRational bytes k = deserializeString bytes (k . fromRational . read)
serializeInteger :: Integer -> [Word8] -> [Word8]
serializeInteger = serializeString . show
deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
deserializeInteger bytes k = deserializeString bytes (k . read)
serializeChar :: Char -> [Word8] -> [Word8]
serializeChar = serializeString . show
deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a
deserializeChar bytes k = deserializeString bytes (k . read)
serializeString :: String -> [Word8] -> [Word8]
serializeString = serializeList serializeEnum
deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
deserializeString = deserializeList deserializeEnum
serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)
deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
-> [Word8] -> ([a] -> [Word8] -> b) -> b
deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
where
go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
go len bytes k
| len <= 0 = k [] bytes
| otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
|
