diff options
Diffstat (limited to 'compiler/utils')
| -rw-r--r-- | compiler/utils/Binary.hs | 22 | ||||
| -rw-r--r-- | compiler/utils/IOEnv.hs | 12 | ||||
| -rw-r--r-- | compiler/utils/MonadUtils.hs | 34 | ||||
| -rw-r--r-- | compiler/utils/Outputable.lhs | 5 | ||||
| -rw-r--r-- | compiler/utils/Serialized.hs | 174 |
5 files changed, 244 insertions, 3 deletions
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 80d10cba66..4f48a424b3 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -75,6 +75,7 @@ import Data.Int import Data.Word import Data.IORef import Data.Char ( ord, chr ) +import Data.Typeable import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -565,6 +566,27 @@ instance Binary (Bin a) where get bh = do i <- get bh; return (BinPtr i) -- ----------------------------------------------------------------------------- +-- Instances for Data.Typeable stuff + +instance Binary TyCon where + put_ bh ty_con = do + let s = tyConString ty_con + put_ bh s + get bh = do + s <- get bh + return (mkTyCon s) + +instance Binary TypeRep where + put_ bh type_rep = do + let (ty_con, child_type_reps) = splitTyConApp type_rep + put_ bh ty_con + put_ bh child_type_reps + get bh = do + ty_con <- get bh + child_type_reps <- get bh + return (mkTyConApp ty_con child_type_reps) + +-- ----------------------------------------------------------------------------- -- Lazy reading/writing lazyPut :: Binary a => BinHandle -> a -> IO () diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 61345ca246..305e30eed7 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -3,6 +3,7 @@ -- -- The IO Monad with an environment -- +{-# LANGUAGE UndecidableInstances #-} module IOEnv ( IOEnv, -- Instance of Monad @@ -31,6 +32,7 @@ import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef ) import Data.Typeable import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO ( fixIO ) +import Control.Monad import MonadUtils ---------------------------------------------------------------------- @@ -132,6 +134,16 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) ---------------------------------------------------------------------- +-- MonadPlus +---------------------------------------------------------------------- + +-- For use if the user has imported Control.Monad.Error from MTL +-- Requires UndecidableInstances +instance MonadPlus IO => MonadPlus (IOEnv env) where + mzero = IOEnv (const mzero) + m `mplus` n = IOEnv (\env -> unIOEnv m env `mplus` unIOEnv n env) + +---------------------------------------------------------------------- -- Accessing input/output ---------------------------------------------------------------------- diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs index 85d8642313..28613a4284 100644 --- a/compiler/utils/MonadUtils.hs +++ b/compiler/utils/MonadUtils.hs @@ -9,10 +9,13 @@ module MonadUtils , MonadFix(..) , MonadIO(..) + , liftIO1, liftIO2, liftIO3, liftIO4 + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M , mapAccumLM , mapSndM , concatMapM + , mapMaybeM , anyM, allM , foldlM, foldrM ) where @@ -33,6 +36,8 @@ module MonadUtils -- Imports ---------------------------------------------------------------------------------------- +import Maybes + #if HAVE_APPLICATIVE import Control.Applicative #endif @@ -77,8 +82,29 @@ instance MonadIO IO where liftIO = id #endif ---------------------------------------------------------------------------------------- +-- Lift combinators +-- These are used throughout the compiler +---------------------------------------------------------------------------------------- + +-- | Lift an 'IO' operation with 1 argument into another monad +liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b +liftIO1 = (.) liftIO + +-- | Lift an 'IO' operation with 2 arguments into another monad +liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c +liftIO2 = ((.).(.)) liftIO + +-- | Lift an 'IO' operation with 3 arguments into another monad +liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d +liftIO3 = ((.).((.).(.))) liftIO + +-- | Lift an 'IO' operation with 4 arguments into another monad +liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e +liftIO4 = (((.).(.)).((.).(.))) liftIO + +---------------------------------------------------------------------------------------- -- Common functions --- These are used throught the compiler +-- These are used throughout the compiler ---------------------------------------------------------------------------------------- -- | mapAndUnzipM for triples @@ -117,6 +143,10 @@ mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs) +-- | Monadic version of mapMaybe +mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = liftM catMaybes . mapM f + -- | Monadic version of 'any', aborts the computation at the first @True@ value anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool anyM _ [] = return False @@ -136,4 +166,4 @@ foldlM = foldM -- | Monadic version of foldr foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a foldrM _ z [] = return z -foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } +foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
\ No newline at end of file diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index 548dc2ca8b..fb0270f169 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -36,7 +36,7 @@ module Outputable ( printSDoc, printErrs, hPrintDump, printDump, printForC, printForAsm, printForUser, printForUserPartWay, pprCode, mkCodeStyle, - showSDoc, showSDocForUser, showSDocDebug, showSDocDump, + showSDoc, showSDocForUser, showSDocDebug, showSDocDump, showPpr, showSDocUnqual, showsPrecSDoc, pprInfixVar, pprPrefixVar, @@ -333,6 +333,9 @@ showSDocDump d = show (d PprDump) showSDocDebug :: SDoc -> String showSDocDebug d = show (d PprDebug) + +showPpr :: Outputable a => a -> String +showPpr = showSDoc . ppr \end{code} \begin{code} diff --git a/compiler/utils/Serialized.hs b/compiler/utils/Serialized.hs new file mode 100644 index 0000000000..9a0e4c5d17 --- /dev/null +++ b/compiler/utils/Serialized.hs @@ -0,0 +1,174 @@ +-- +-- (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 |