compiler/utils/Serialized.hs

   1 --
   2 -- (c) The University of Glasgow 2002-2006
   3 --
   4 -- Serialized values
   5
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 module Serialized (
   8     -- * Main Serialized data type
   9     Serialized,
  10     seqSerialized,
  11
  12     -- * Going into and out of 'Serialized'
  13     toSerialized, fromSerialized,
  14
  15     -- * Handy serialization functions
  16     serializeWithData, deserializeWithData,
  17   ) where
  18
  19 import Binary
  20 import Outputable
  21 import FastString
  22 import Util
  23
  24 import Data.Bits
  25 import Data.Word        ( Word8 )
  26
  27 #if __GLASGOW_HASKELL__ > 609
  28 import Data.Data
  29 #else
  30 import Data.Generics
  31 #endif
  32 import Data.Typeable
  33
  34
  35 -- | Represents a serialized value of a particular type. Attempts can be made to deserialize it at certain types
  36 data Serialized = Serialized TypeRep [Word8]
  37
  38 instance Outputable Serialized where
  39     ppr (Serialized the_type bytes) = int (length bytes) <+> ptext (sLit "of type") <+> text (show the_type)
  40
  41 instance Binary Serialized where
  42     put_ bh (Serialized the_type bytes) = do
  43         put_ bh the_type
  44         put_ bh bytes
  45     get bh = do
  46         the_type <- get bh
  47         bytes <- get bh
  48         return (Serialized the_type bytes)
  49
  50 -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later
  51 toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized
  52 toSerialized serialize what = Serialized (typeOf what) (serialize what)
  53
  54 -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that.
  55 -- Otherwise return @Nothing@.
  56 fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
  57 fromSerialized deserialize (Serialized the_type bytes)
  58   | the_type == typeOf (undefined :: a) = Just (deserialize bytes)
  59   | otherwise                           = Nothing
  60
  61 -- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms
  62 seqSerialized :: Serialized -> ()
  63 seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()
  64
  65
  66 -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData'
  67 serializeWithData :: Data a => a -> [Word8]
  68 serializeWithData what = serializeWithData' what []
  69
  70 serializeWithData' :: Data a => a -> [Word8] -> [Word8]
  71 serializeWithData' what = fst $ gfoldl (\(before, a_to_b) a -> (before . serializeWithData' a, a_to_b a))
  72                                        (\x -> (serializeConstr (constrRep (toConstr what)), x))
  73                                        what
  74
  75 -- | Use a 'Data' instance to implement a deserialization scheme dual to that of 'serializeWithData'
  76 deserializeWithData :: Data a => [Word8] -> a
  77 deserializeWithData = snd . deserializeWithData'
  78
  79 deserializeWithData' :: forall a. Data a => [Word8] -> ([Word8], a)
  80 deserializeWithData' bytes = deserializeConstr bytes $ \constr_rep bytes ->
  81                              gunfold (\(bytes, b_to_r) -> let (bytes', b) = deserializeWithData' bytes in (bytes', b_to_r b))
  82                                      (\x -> (bytes, x))
  83                                      (repConstr (dataTypeOf (undefined :: a)) constr_rep)
  84
  85
  86 serializeConstr :: ConstrRep -> [Word8] -> [Word8]
  87 serializeConstr (AlgConstr ix)   = serializeWord8 1 . serializeInt ix
  88 serializeConstr (IntConstr i)    = serializeWord8 2 . serializeInteger i
  89 serializeConstr (FloatConstr r)  = serializeWord8 3 . serializeRational r
  90 #if __GLASGOW_HASKELL__ < 611
  91 serializeConstr (StringConstr s) = serializeWord8 4 . serializeString s
  92 #else
  93 serializeConstr (CharConstr c)   = serializeWord8 4 . serializeChar c
  94 #endif
  95
  96
  97 deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a
  98 deserializeConstr bytes k = deserializeWord8 bytes $ \constr_ix bytes ->
  99                             case constr_ix of
 100                                 1 -> deserializeInt      bytes $ \ix -> k (AlgConstr ix)
 101                                 2 -> deserializeInteger  bytes $ \i  -> k (IntConstr i)
 102                                 3 -> deserializeRational bytes $ \r  -> k (FloatConstr r)
 103 #if __GLASGOW_HASKELL__ >= 611
 104                                 4 -> deserializeChar     bytes $ \c  -> k (CharConstr c)
 105 #else
 106                                 4 -> deserializeString   bytes $ \s  -> k (StringConstr s)
 107 #endif
 108                                 x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
 109
 110
 111 serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8]
 112 serializeFixedWidthNum what = go (bitSize what) what
 113   where
 114     go :: Int -> a -> [Word8] -> [Word8]
 115     go size current rest
 116       | size <= 0 = rest
 117       | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
 118
 119 deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b
 120 deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k
 121   where
 122     go :: Int -> [Word8] -> (a -> [Word8] -> b) -> b
 123     go size bytes k
 124       | size <= 0 = k 0 bytes
 125       | otherwise = case bytes of
 126                         (byte:bytes) -> go (size - 8) bytes (\x -> k ((x `shiftL` 8) .|. fromIntegral byte))
 127                         []           -> error "deserializeFixedWidthNum: unexpected end of stream"
 128
 129
 130 serializeEnum :: (Enum a) => a -> [Word8] -> [Word8]
 131 serializeEnum = serializeInt . fromEnum
 132
 133 deserializeEnum :: Enum a => [Word8] -> (a -> [Word8] -> b) -> b
 134 deserializeEnum bytes k = deserializeInt bytes (k . toEnum)
 135
 136
 137 serializeWord8 :: Word8 -> [Word8] -> [Word8]
 138 serializeWord8 x = (x:)
 139
 140 deserializeWord8 :: [Word8] -> (Word8 -> [Word8] -> a) -> a
 141 deserializeWord8 (byte:bytes) k = k byte bytes
 142 deserializeWord8 []           _ = error "deserializeWord8: unexpected end of stream"
 143
 144
 145 serializeInt :: Int -> [Word8] -> [Word8]
 146 serializeInt = serializeFixedWidthNum
 147
 148 deserializeInt :: [Word8] -> (Int -> [Word8] -> a) -> a
 149 deserializeInt = deserializeFixedWidthNum
 150
 151
 152 serializeRational :: (Real a) => a -> [Word8] -> [Word8]
 153 serializeRational = serializeString . show . toRational
 154
 155 deserializeRational :: (Fractional a) => [Word8] -> (a -> [Word8] -> b) -> b
 156 deserializeRational bytes k = deserializeString bytes (k . fromRational . read)
 157
 158
 159 serializeInteger :: Integer -> [Word8] -> [Word8]
 160 serializeInteger = serializeString . show
 161
 162 deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
 163 deserializeInteger bytes k = deserializeString bytes (k . read)
 164
 165
 166 #if __GLASGOW_HASKELL__ >= 611
 167 serializeChar :: Char -> [Word8] -> [Word8]
 168 serializeChar = serializeString . show
 169
 170 deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a
 171 deserializeChar bytes k = deserializeString bytes (k . read)
 172 #endif
 173
 174
 175 serializeString :: String -> [Word8] -> [Word8]
 176 serializeString = serializeList serializeEnum
 177
 178 deserializeString :: [Word8] -> (String -> [Word8] -> a) -> a
 179 deserializeString = deserializeList deserializeEnum
 180
 181
 182 serializeList :: (a -> [Word8] -> [Word8]) -> [a] -> [Word8] -> [Word8]
 183 serializeList serialize_element xs = serializeInt (length xs) . foldr (.) id (map serialize_element xs)
 184
 185 deserializeList :: forall a b. (forall c. [Word8] -> (a -> [Word8] -> c) -> c)
 186                 -> [Word8] -> ([a] -> [Word8] -> b) -> b
 187 deserializeList deserialize_element bytes k = deserializeInt bytes $ \len bytes -> go len bytes k
 188   where
 189     go :: Int -> [Word8] -> ([a] -> [Word8] -> b) -> b
 190     go len bytes k
 191       | len <= 0  = k [] bytes
 192       | otherwise = deserialize_element bytes (\elt bytes -> go (len - 1) bytes (k . (elt:)))
 193