X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FData.hs;h=d9cab7a5e9365d6194d03fa1e59b06af68d3d00d;hb=41e8fba828acbae1751628af50849f5352b27873;hp=f812c3076c012cbdcc676e1b761d871750257287;hpb=a19d2f066c4c39bcff7bc6e64ad008085f4329f7;p=ghc-base.git

diff --git a/Data/Data.hs b/Data/Data.hs
index f812c30..d9cab7a 100644
--- a/Data/Data.hs
+++ b/Data/Data.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Data
@@ -54,6 +56,7 @@ module Data.Data (
         mkIntType,      -- :: String -> DataType
         mkFloatType,    -- :: String -> DataType
         mkStringType,   -- :: String -> DataType
+        mkCharType,     -- :: String -> DataType
         mkNoRepType,    -- :: String -> DataType
         mkNorepType,    -- :: String -> DataType
         -- ** Observers
@@ -75,8 +78,11 @@ module Data.Data (
         -- ** Constructors
         mkConstr,       -- :: DataType -> String -> Fixity -> Constr
         mkIntConstr,    -- :: DataType -> Integer -> Constr
-        mkFloatConstr,  -- :: DataType -> Double  -> Constr
+        mkFloatConstr,  -- :: DataType -> Double -> Constr
+        mkIntegralConstr,-- :: (Integral a) => DataType -> a -> Constr
+        mkRealConstr,   -- :: (Real a) => DataType -> a -> Constr
         mkStringConstr, -- :: DataType -> String  -> Constr
+        mkCharConstr,   -- :: DataType -> Char -> Constr
         -- ** Observers
         constrType,     -- :: Constr   -> DataType
         ConstrRep(..),  -- instance of: Eq, Show
@@ -110,7 +116,6 @@ import Data.Maybe
 import Control.Monad
 
 -- Imports for the instances
-import Data.Typeable
 import Data.Int              -- So we can give Data instance for Int8, ...
 import Data.Word             -- So we can give Data instance for Word8, ...
 #ifdef __GLASGOW_HASKELL__
@@ -307,20 +312,24 @@ class Typeable a => Data a where
   --
   gmapT f x0 = unID (gfoldl k ID x0)
     where
+      k :: Data d => ID (d->b) -> d -> ID b
       k (ID c) x = ID (c (f x))
 
 
   -- | A generic query with a left-associative binary operator
-  gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
+  gmapQl :: forall r r'. (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
   gmapQl o r f = unCONST . gfoldl k z
     where
+      k :: Data d => CONST r (d->b) -> d -> CONST r b
       k c x = CONST $ (unCONST c) `o` f x
+      z :: g -> CONST r g
       z _   = CONST r
 
   -- | A generic query with a right-associative binary operator
-  gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
+  gmapQr :: forall r r'. (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r
   gmapQr o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0
     where
+      k :: Data d => Qr r (d->b) -> d -> Qr r b
       k (Qr c) x = Qr (\r -> c (f x `o` r))
 
 
@@ -332,10 +341,12 @@ class Typeable a => Data a where
 
 
   -- | A generic query that processes one child by index (zero-based)
-  gmapQi :: Int -> (forall d. Data d => d -> u) -> a -> u
+  gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> a -> u
   gmapQi i f x = case gfoldl k z x of { Qi _ q -> fromJust q }
     where
+      k :: Data d => Qi u (d -> b) -> d -> Qi u b
       k (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q)
+      z :: g -> Qi q g
       z _           = Qi 0 Nothing
 
 
@@ -344,7 +355,7 @@ class Typeable a => Data a where
   -- The default definition instantiates the type constructor @c@ in
   -- the type of 'gfoldl' to the monad datatype constructor, defining
   -- injection and projection using 'return' and '>>='.
-  gmapM   :: Monad m => (forall d. Data d => d -> m d) -> a -> m a
+  gmapM :: forall m. Monad m => (forall d. Data d => d -> m d) -> a -> m a
 
   -- Use immediately the monad datatype constructor 
   -- to instantiate the type constructor c in the type of gfoldl,
@@ -352,13 +363,14 @@ class Typeable a => Data a where
   --  
   gmapM f = gfoldl k return
     where
+      k :: Data d => m (d -> b) -> d -> m b
       k c x = do c' <- c
                  x' <- f x
                  return (c' x')
 
 
   -- | Transformation of at least one immediate subterm does not fail
-  gmapMp :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
+  gmapMp :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
 
 {-
 
@@ -371,7 +383,9 @@ this end, we couple the monadic computation with a Boolean.
   gmapMp f x = unMp (gfoldl k z x) >>= \(x',b) ->
                 if b then return x' else mzero
     where
+      z :: g -> Mp m g
       z g = Mp (return (g,False))
+      k :: Data d => Mp m (d -> b) -> d -> Mp m b
       k (Mp c) y
         = Mp ( c >>= \(h, b) ->
                  (f y >>= \y' -> return (h y', True))
@@ -379,7 +393,7 @@ this end, we couple the monadic computation with a Boolean.
              )
 
   -- | Transformation of one immediate subterm with success
-  gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
+  gmapMo :: forall m. MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a
 
 {-
 
@@ -394,7 +408,9 @@ was transformed successfully.
   gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) ->
                 if b then return x' else mzero
     where
+      z :: g -> Mp m g
       z g = Mp (return (g,False))
+      k :: Data d => Mp m (d -> b) -> d -> Mp m b
       k (Mp c) y
         = Mp ( c >>= \(h,b) -> if b
                         then return (h y, b)
@@ -443,18 +459,24 @@ fromConstrB :: Data a
             -> a
 fromConstrB f = unID . gunfold k z
  where
+  k :: forall b r. Data b => ID (b -> r) -> ID r
   k c = ID (unID c f)
+ 
+  z :: forall r. r -> ID r
   z = ID
 
 
 -- | Monadic variation on 'fromConstrB'
-fromConstrM :: (Monad m, Data a)
+fromConstrM :: forall m a. (Monad m, Data a)
             => (forall d. Data d => m d)
             -> Constr
             -> m a
 fromConstrM f = gunfold k z
  where
+  k :: forall b r. Data b => m (b -> r) -> m r
   k c = do { c' <- c; b <- f; return (c' b) }
+
+  z :: forall r. r -> m r
   z = return
 
 
@@ -477,8 +499,9 @@ data DataType = DataType
 
               deriving Show
 
-
--- | Representation of constructors
+-- | Representation of constructors. Note that equality on constructors
+-- with different types may not work -- i.e. the constructors for 'False' and
+-- 'Nothing' may compare equal.
 data Constr = Constr
                         { conrep    :: ConstrRep
                         , constring :: String
@@ -500,7 +523,7 @@ instance Eq Constr where
 data DataRep = AlgRep [Constr]
              | IntRep
              | FloatRep
-             | StringRep
+             | CharRep
              | NoRep
 
             deriving (Eq,Show)
@@ -510,8 +533,8 @@ data DataRep = AlgRep [Constr]
 -- | Public representation of constructors
 data ConstrRep = AlgConstr    ConIndex
                | IntConstr    Integer
-               | FloatConstr  Double
-               | StringConstr String
+               | FloatConstr  Rational
+               | CharConstr   Char
 
                deriving (Eq,Show)
 
@@ -562,8 +585,8 @@ repConstr dt cr =
       case (dataTypeRep dt, cr) of
         (AlgRep cs, AlgConstr i)      -> cs !! (i-1)
         (IntRep,    IntConstr i)      -> mkIntConstr dt i
-        (FloatRep,  FloatConstr f)    -> mkFloatConstr dt f
-        (StringRep, StringConstr str) -> mkStringConstr dt str
+        (FloatRep,  FloatConstr f)    -> mkRealConstr dt f
+        (CharRep,   CharConstr c)     -> mkCharConstr dt c
         _ -> error "repConstr"
 
 
@@ -636,8 +659,8 @@ readConstr dt str =
       case dataTypeRep dt of
         AlgRep cons -> idx cons
         IntRep      -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
-        FloatRep    -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
-        StringRep   -> Just (mkStringConstr dt str)
+        FloatRep    -> mkReadCon ffloat
+        CharRep     -> mkReadCon (\c -> (mkPrimCon dt str (CharConstr c)))
         NoRep       -> Nothing
   where
 
@@ -654,6 +677,8 @@ readConstr dt str =
                      then Nothing
                      else Just (head fit)
 
+    ffloat :: Double -> Constr
+    ffloat =  mkPrimCon dt str . FloatConstr . toRational
 
 ------------------------------------------------------------------------------
 --
@@ -708,9 +733,14 @@ mkFloatType :: String -> DataType
 mkFloatType = mkPrimType FloatRep
 
 
--- | Constructs the 'String' type
+-- | This function is now deprecated. Please use 'mkCharType' instead.
+{-# DEPRECATED mkStringType "Use mkCharType instead" #-}
 mkStringType :: String -> DataType
-mkStringType = mkPrimType StringRep
+mkStringType = mkCharType
+
+-- | Constructs the 'Char' type
+mkCharType :: String -> DataType
+mkCharType = mkPrimType CharRep
 
 
 -- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType'
@@ -731,23 +761,41 @@ mkPrimCon dt str cr = Constr
                         , confixity = error "constrFixity"
                         }
 
-
+-- | This function is now deprecated. Please use 'mkIntegralConstr' instead.
+{-# DEPRECATED mkIntConstr "Use mkIntegralConstr instead" #-}
 mkIntConstr :: DataType -> Integer -> Constr
-mkIntConstr dt i = case datarep dt of
-                  IntRep -> mkPrimCon dt (show i) (IntConstr i)
-                  _ -> error "mkIntConstr"
+mkIntConstr = mkIntegralConstr
 
+mkIntegralConstr :: (Integral a) => DataType -> a -> Constr
+mkIntegralConstr dt i = case datarep dt of
+                  IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger  i))
+                  _ -> error "mkIntegralConstr"
 
+-- | This function is now deprecated. Please use 'mkRealConstr' instead.
+{-# DEPRECATED mkFloatConstr "Use mkRealConstr instead" #-}
 mkFloatConstr :: DataType -> Double -> Constr
-mkFloatConstr dt f = case datarep dt of
-                    FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
-                    _ -> error "mkFloatConstr"
+mkFloatConstr dt = mkRealConstr dt . toRational
 
+mkRealConstr :: (Real a) => DataType -> a -> Constr
+mkRealConstr dt f = case datarep dt of
+                    FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f))
+                    _ -> error "mkRealConstr"
 
+-- | This function is now deprecated. Please use 'mkCharConstr' instead.
+{-# DEPRECATED mkStringConstr "Use mkCharConstr instead" #-}
 mkStringConstr :: DataType -> String -> Constr
-mkStringConstr dt str = case datarep dt of
-                       StringRep -> mkPrimCon dt str (StringConstr str)
-                       _ -> error "mkStringConstr"
+mkStringConstr dt str =
+  case datarep dt of
+    CharRep -> case str of
+      [c] -> mkPrimCon dt (show c) (CharConstr c)
+      _ -> error "mkStringConstr: input String must contain a single character"
+    _ -> error "mkStringConstr"
+
+-- | Makes a constructor for 'Char'.
+mkCharConstr :: DataType -> Char -> Constr
+mkCharConstr dt c = case datarep dt of
+                   CharRep -> mkPrimCon dt (show c) (CharConstr c)
+                   _ -> error "mkCharConstr"
 
 
 ------------------------------------------------------------------------------
@@ -839,12 +887,12 @@ instance Data Bool where
 ------------------------------------------------------------------------------
 
 charType :: DataType
-charType = mkStringType "Prelude.Char"
+charType = mkCharType "Prelude.Char"
 
 instance Data Char where
-  toConstr x = mkStringConstr charType [x]
+  toConstr x = mkCharConstr charType x
   gunfold _ z c = case constrRep c of
-                    (StringConstr [x]) -> z x
+                    (CharConstr x) -> z x
                     _ -> error "gunfold"
   dataTypeOf _ = charType
 
@@ -855,7 +903,7 @@ floatType :: DataType
 floatType = mkFloatType "Prelude.Float"
 
 instance Data Float where
-  toConstr x = mkFloatConstr floatType (realToFrac x)
+  toConstr = mkRealConstr floatType
   gunfold _ z c = case constrRep c of
                     (FloatConstr x) -> z (realToFrac x)
                     _ -> error "gunfold"
@@ -868,9 +916,9 @@ doubleType :: DataType
 doubleType = mkFloatType "Prelude.Double"
 
 instance Data Double where
-  toConstr = mkFloatConstr floatType
+  toConstr = mkRealConstr doubleType
   gunfold _ z c = case constrRep c of
-                    (FloatConstr x) -> z x
+                    (FloatConstr x) -> z (realToFrac x)
                     _ -> error "gunfold"
   dataTypeOf _ = doubleType