summaryrefslogtreecommitdiff
path: root/compiler/utils/Serialized.hs
blob: 902d2feea06c1e5155c4c60831f2d75fa30cfe8b (plain)
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:)))