+{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : Data.Data
mkIntType, -- :: String -> DataType
mkFloatType, -- :: String -> DataType
mkStringType, -- :: String -> DataType
+ mkCharType, -- :: String -> DataType
+ mkNoRepType, -- :: String -> DataType
mkNorepType, -- :: String -> DataType
-- ** Observers
dataTypeName, -- :: DataType -> String
-- ** 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
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__
--
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))
-- | 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
-- 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,
--
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
{-
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))
)
-- | 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
{-
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)
-> 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
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
data DataRep = AlgRep [Constr]
| IntRep
| FloatRep
- | StringRep
+ | CharRep
| NoRep
deriving (Eq,Show)
-- | Public representation of constructors
data ConstrRep = AlgConstr ConIndex
| IntConstr Integer
- | FloatConstr Double
- | StringConstr String
+ | FloatConstr Rational
+ | CharConstr Char
deriving (Eq,Show)
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"
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
then Nothing
else Just (head fit)
+ ffloat :: Double -> Constr
+ ffloat = mkPrimCon dt str . FloatConstr . toRational
------------------------------------------------------------------------------
--
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'
, 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"
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--- | Constructs a non-representation for a non-presentable type
+-- | Deprecated version (misnamed)
+{-# DEPRECATED mkNorepType "Use mkNoRepType instead" #-}
mkNorepType :: String -> DataType
mkNorepType str = DataType
{ tycon = str
, datarep = NoRep
}
+-- | Constructs a non-representation for a non-presentable type
+mkNoRepType :: String -> DataType
+mkNoRepType str = DataType
+ { tycon = str
+ , datarep = NoRep
+ }
-- | Test for a non-representable type
isNorepType :: DataType -> Bool
------------------------------------------------------------------------------
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
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"
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
instance Typeable a => Data (Ptr a) where
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.Ptr.Ptr"
+ dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr"
------------------------------------------------------------------------------
instance Typeable a => Data (ForeignPtr a) where
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "GHC.ForeignPtr.ForeignPtr"
+ dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr"
------------------------------------------------------------------------------
gfoldl f z a = z (listArray (bounds a)) `f` (elems a)
toConstr _ = error "toConstr"
gunfold _ _ = error "gunfold"
- dataTypeOf _ = mkNorepType "Data.Array.Array"
+ dataTypeOf _ = mkNoRepType "Data.Array.Array"
projects / ghc-base.git / blobdiff