--- /dev/null
+--
+-- (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 )
+
+#if __GLASGOW_HASKELL__ > 609
+import Data.Data
+#else
+import Data.Generics
+#endif
+import Data.Typeable
+
+
+-- | 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 d) = serializeWord8 3 . serializeDouble d
+serializeConstr (StringConstr s) = serializeWord8 4 . serializeString s
+
+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 -> deserializeDouble bytes $ \d -> k (FloatConstr d)
+ 4 -> deserializeString bytes $ \s -> k (StringConstr s)
+ x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes
+
+
+serializeFixedWidthNum :: forall a. (Num a, Integral a, Bits a) => a -> [Word8] -> [Word8]
+serializeFixedWidthNum what = go (bitSize what) what
+ where
+ go :: Int -> a -> [Word8] -> [Word8]
+ go size current rest
+ | size <= 0 = rest
+ | otherwise = fromIntegral (current .&. 255) : go (size - 8) (current `shiftR` 8) rest
+
+deserializeFixedWidthNum :: forall a b. (Num a, Integral a, Bits a) => [Word8] -> (a -> [Word8] -> b) -> b
+deserializeFixedWidthNum bytes k = go (bitSize (undefined :: a)) bytes k
+ 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
+
+
+serializeDouble :: Double -> [Word8] -> [Word8]
+serializeDouble = serializeString . show
+
+deserializeDouble :: [Word8] -> (Double -> [Word8] -> a) -> a
+deserializeDouble bytes k = deserializeString bytes (k . read)
+
+
+serializeInteger :: Integer -> [Word8] -> [Word8]
+serializeInteger = serializeString . show
+
+deserializeInteger :: [Word8] -> (Integer -> [Word8] -> a) -> a
+deserializeInteger 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:)))
\ No newline at end of file
projects / ghc-hetmet.git / blobdiff