From 5a9e76d24776608a3e14ba94f1dfa0cac072c251 Mon Sep 17 00:00:00 2001 From: 'Jose Pedro Magalhaes Date: Thu, 2 Oct 2008 14:05:35 +0000 Subject: [PATCH] added new module Data.Data The new Data.Data module contains all of Data.Generics.Basics and most of Data.Generics.Instances. The missing instances were deemed dubious and moved to the syb package. --- Data/Data.hs | 1298 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1298 insertions(+) create mode 100644 Data/Data.hs diff --git a/Data/Data.hs b/Data/Data.hs new file mode 100644 index 0000000..10aa17e --- /dev/null +++ b/Data/Data.hs @@ -0,0 +1,1298 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Data +-- Copyright : (c) The University of Glasgow, CWI 2001--2004 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (local universal quantification) +-- +-- \"Scrap your boilerplate\" --- Generic programming in Haskell. +-- See . This module provides +-- the 'Data' class with its primitives for generic programming, along +-- with instances for many datatypes. It corresponds to a merge between +-- the previous "Data.Generics.Basics" and almost all of +-- "Data.Generics.Instances". The instances that are not present +-- in this module are available in "Data.Generics.Instances". +-- +-- +----------------------------------------------------------------------------- + +module Data.Data ( + + -- * Module Data.Typeable re-exported for convenience + module Data.Typeable, + + -- * The Data class for processing constructor applications + Data( + gfoldl, -- :: ... -> a -> c a + gunfold, -- :: ... -> Constr -> c a + toConstr, -- :: a -> Constr + dataTypeOf, -- :: a -> DataType + dataCast1, -- mediate types and unary type constructors + dataCast2, -- mediate types and binary type constructors + -- Generic maps defined in terms of gfoldl + gmapT, + gmapQ, + gmapQl, + gmapQr, + gmapQi, + gmapM, + gmapMp, + gmapMo + ), + + -- * Datatype representations + DataType, -- abstract, instance of: Show + -- ** Constructors + mkDataType, -- :: String -> [Constr] -> DataType + mkIntType, -- :: String -> DataType + mkFloatType, -- :: String -> DataType + mkStringType, -- :: String -> DataType + mkNorepType, -- :: String -> DataType + -- ** Observers + dataTypeName, -- :: DataType -> String + DataRep(..), -- instance of: Eq, Show + dataTypeRep, -- :: DataType -> DataRep + -- ** Convenience functions + repConstr, -- :: DataType -> ConstrRep -> Constr + isAlgType, -- :: DataType -> Bool + dataTypeConstrs,-- :: DataType -> [Constr] + indexConstr, -- :: DataType -> ConIndex -> Constr + maxConstrIndex, -- :: DataType -> ConIndex + isNorepType, -- :: DataType -> Bool + + -- * Data constructor representations + Constr, -- abstract, instance of: Eq, Show + ConIndex, -- alias for Int, start at 1 + Fixity(..), -- instance of: Eq, Show + -- ** Constructors + mkConstr, -- :: DataType -> String -> Fixity -> Constr + mkIntConstr, -- :: DataType -> Integer -> Constr + mkFloatConstr, -- :: DataType -> Double -> Constr + mkStringConstr, -- :: DataType -> String -> Constr + -- ** Observers + constrType, -- :: Constr -> DataType + ConstrRep(..), -- instance of: Eq, Show + constrRep, -- :: Constr -> ConstrRep + constrFields, -- :: Constr -> [String] + constrFixity, -- :: Constr -> Fixity + -- ** Convenience function: algebraic data types + constrIndex, -- :: Constr -> ConIndex + -- ** From strings to constructors and vice versa: all data types + showConstr, -- :: Constr -> String + readConstr, -- :: DataType -> String -> Maybe Constr + + -- * Convenience functions: take type constructors apart + tyconUQname, -- :: String -> String + tyconModule, -- :: String -> String + + -- * Generic operations defined in terms of 'gunfold' + fromConstr, -- :: Constr -> a + fromConstrB, -- :: ... -> Constr -> a + fromConstrM -- :: Monad m => ... -> Constr -> m a + + ) where + + +------------------------------------------------------------------------------ + +import Prelude -- necessary to get dependencies right + +import Data.Typeable +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__ +import GHC.Real( Ratio(..) ) -- So we can give Data instance for Ratio +--import GHC.IOBase -- So we can give Data instance for IO, Handle +import GHC.Ptr -- So we can give Data instance for Ptr +import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr +--import GHC.Stable -- So we can give Data instance for StablePtr +--import GHC.ST -- So we can give Data instance for ST +--import GHC.Conc -- So we can give Data instance for MVar & Co. +import GHC.Arr -- So we can give Data instance for Array +#else +# ifdef __HUGS__ +import Hugs.Prelude( Ratio(..) ) +# endif +import System.IO +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.StablePtr +import Control.Monad.ST +import Control.Concurrent +import Data.Array +import Data.IORef +#endif + +#include "Typeable.h" + + + +------------------------------------------------------------------------------ +-- +-- The Data class +-- +------------------------------------------------------------------------------ + +{- | +The 'Data' class comprehends a fundamental primitive 'gfoldl' for +folding over constructor applications, say terms. This primitive can +be instantiated in several ways to map over the immediate subterms +of a term; see the @gmap@ combinators later in this class. Indeed, a +generic programmer does not necessarily need to use the ingenious gfoldl +primitive but rather the intuitive @gmap@ combinators. The 'gfoldl' +primitive is completed by means to query top-level constructors, to +turn constructor representations into proper terms, and to list all +possible datatype constructors. This completion allows us to serve +generic programming scenarios like read, show, equality, term generation. + +The combinators 'gmapT', 'gmapQ', 'gmapM', etc are all provided with +default definitions in terms of 'gfoldl', leaving open the opportunity +to provide datatype-specific definitions. +(The inclusion of the @gmap@ combinators as members of class 'Data' +allows the programmer or the compiler to derive specialised, and maybe +more efficient code per datatype. /Note/: 'gfoldl' is more higher-order +than the @gmap@ combinators. This is subject to ongoing benchmarking +experiments. It might turn out that the @gmap@ combinators will be +moved out of the class 'Data'.) + +Conceptually, the definition of the @gmap@ combinators in terms of the +primitive 'gfoldl' requires the identification of the 'gfoldl' function +arguments. Technically, we also need to identify the type constructor +@c@ for the construction of the result type from the folded term type. + +In the definition of @gmapQ@/x/ combinators, we use phantom type +constructors for the @c@ in the type of 'gfoldl' because the result type +of a query does not involve the (polymorphic) type of the term argument. +In the definition of 'gmapQl' we simply use the plain constant type +constructor because 'gfoldl' is left-associative anyway and so it is +readily suited to fold a left-associative binary operation over the +immediate subterms. In the definition of gmapQr, extra effort is +needed. We use a higher-order accumulation trick to mediate between +left-associative constructor application vs. right-associative binary +operation (e.g., @(:)@). When the query is meant to compute a value +of type @r@, then the result type withing generic folding is @r -> r@. +So the result of folding is a function to which we finally pass the +right unit. + +With the @-XDeriveDataTypeable@ option, GHC can generate instances of the +'Data' class automatically. For example, given the declaration + +> data T a b = C1 a b | C2 deriving (Typeable, Data) + +GHC will generate an instance that is equivalent to + +> instance (Data a, Data b) => Data (T a b) where +> gfoldl k z (C1 a b) = z C1 `k` a `k` b +> gfoldl k z C2 = z C2 +> +> gunfold k z c = case constrIndex c of +> 1 -> k (k (z C1)) +> 2 -> z C2 +> +> toConstr (C1 _ _) = con_C1 +> toConstr C2 = con_C2 +> +> dataTypeOf _ = ty_T +> +> con_C1 = mkConstr ty_T "C1" [] Prefix +> con_C2 = mkConstr ty_T "C2" [] Prefix +> ty_T = mkDataType "Module.T" [con_C1, con_C2] + +This is suitable for datatypes that are exported transparently. + +-} + +class Typeable a => Data a where + + -- | Left-associative fold operation for constructor applications. + -- + -- The type of 'gfoldl' is a headache, but operationally it is a simple + -- generalisation of a list fold. + -- + -- The default definition for 'gfoldl' is @'const' 'id'@, which is + -- suitable for abstract datatypes with no substructures. + gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b) + -- ^ defines how nonempty constructor applications are + -- folded. It takes the folded tail of the constructor + -- application and its head, i.e., an immediate subterm, + -- and combines them in some way. + -> (forall g. g -> c g) + -- ^ defines how the empty constructor application is + -- folded, like the neutral \/ start element for list + -- folding. + -> a + -- ^ structure to be folded. + -> c a + -- ^ result, with a type defined in terms of @a@, but + -- variability is achieved by means of type constructor + -- @c@ for the construction of the actual result type. + + -- See the 'Data' instances in this file for an illustration of 'gfoldl'. + + gfoldl _ z = z + + -- | Unfolding constructor applications + gunfold :: (forall b r. Data b => c (b -> r) -> c r) + -> (forall r. r -> c r) + -> Constr + -> c a + + -- | Obtaining the constructor from a given datum. + -- For proper terms, this is meant to be the top-level constructor. + -- Primitive datatypes are here viewed as potentially infinite sets of + -- values (i.e., constructors). + toConstr :: a -> Constr + + + -- | The outer type constructor of the type + dataTypeOf :: a -> DataType + + + +------------------------------------------------------------------------------ +-- +-- Mediate types and type constructors +-- +------------------------------------------------------------------------------ + + -- | Mediate types and unary type constructors. + -- In 'Data' instances of the form @T a@, 'dataCast1' should be defined + -- as 'gcast1'. + -- + -- The default definition is @'const' 'Nothing'@, which is appropriate + -- for non-unary type constructors. + dataCast1 :: Typeable1 t + => (forall d. Data d => c (t d)) + -> Maybe (c a) + dataCast1 _ = Nothing + + -- | Mediate types and binary type constructors. + -- In 'Data' instances of the form @T a b@, 'dataCast2' should be + -- defined as 'gcast2'. + -- + -- The default definition is @'const' 'Nothing'@, which is appropriate + -- for non-binary type constructors. + dataCast2 :: Typeable2 t + => (forall d e. (Data d, Data e) => c (t d e)) + -> Maybe (c a) + dataCast2 _ = Nothing + + + +------------------------------------------------------------------------------ +-- +-- Typical generic maps defined in terms of gfoldl +-- +------------------------------------------------------------------------------ + + + -- | A generic transformation that maps over the immediate subterms + -- + -- The default definition instantiates the type constructor @c@ in the + -- type of 'gfoldl' to an identity datatype constructor, using the + -- isomorphism pair as injection and projection. + gmapT :: (forall b. Data b => b -> b) -> a -> a + + -- Use an identity datatype constructor ID (see below) + -- to instantiate the type constructor c in the type of gfoldl, + -- and perform injections ID and projections unID accordingly. + -- + gmapT f x0 = unID (gfoldl k ID x0) + where + 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 o r f = unCONST . gfoldl k z + where + k c x = CONST $ (unCONST c) `o` f x + 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 o r0 f x0 = unQr (gfoldl k (const (Qr id)) x0) r0 + where + k (Qr c) x = Qr (\r -> c (f x `o` r)) + + + -- | A generic query that processes the immediate subterms and returns a list + -- of results. The list is given in the same order as originally specified + -- in the declaratoin of the data constructors. + gmapQ :: (forall d. Data d => d -> u) -> a -> [u] + gmapQ f = gmapQr (:) [] f + + + -- | A generic query that processes one child by index (zero-based) + gmapQi :: 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 (Qi i' q) a = Qi (i'+1) (if i==i' then Just (f a) else q) + z _ = Qi 0 Nothing + + + -- | A generic monadic transformation that maps over the immediate subterms + -- + -- 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 + + -- Use immediately the monad datatype constructor + -- to instantiate the type constructor c in the type of gfoldl, + -- so injection and projection is done by return and >>=. + -- + gmapM f = gfoldl k return + where + 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 + +{- + +The type constructor that we use here simply keeps track of the fact +if we already succeeded for an immediate subterm; see Mp below. To +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 (return (g,False)) + k (Mp c) y + = Mp ( c >>= \(h, b) -> + (f y >>= \y' -> return (h y', True)) + `mplus` return (h y, b) + ) + + -- | Transformation of one immediate subterm with success + gmapMo :: MonadPlus m => (forall d. Data d => d -> m d) -> a -> m a + +{- + +We use the same pairing trick as for gmapMp, +i.e., we use an extra Bool component to keep track of the +fact whether an immediate subterm was processed successfully. +However, we cut of mapping over subterms once a first subterm +was transformed successfully. + +-} + + gmapMo f x = unMp (gfoldl k z x) >>= \(x',b) -> + if b then return x' else mzero + where + z g = Mp (return (g,False)) + k (Mp c) y + = Mp ( c >>= \(h,b) -> if b + then return (h y, b) + else (f y >>= \y' -> return (h y',True)) + `mplus` return (h y, b) + ) + + +-- | The identity type constructor needed for the definition of gmapT +newtype ID x = ID { unID :: x } + + +-- | The constant type constructor needed for the definition of gmapQl +newtype CONST c a = CONST { unCONST :: c } + + +-- | Type constructor for adding counters to queries +data Qi q a = Qi Int (Maybe q) + + +-- | The type constructor used in definition of gmapQr +newtype Qr r a = Qr { unQr :: r -> r } + + +-- | The type constructor used in definition of gmapMp +newtype Mp m x = Mp { unMp :: m (x, Bool) } + + + +------------------------------------------------------------------------------ +-- +-- Generic unfolding +-- +------------------------------------------------------------------------------ + + +-- | Build a term skeleton +fromConstr :: Data a => Constr -> a +fromConstr = fromConstrB undefined + + +-- | Build a term and use a generic function for subterms +fromConstrB :: Data a + => (forall d. Data d => d) + -> Constr + -> a +fromConstrB f = unID . gunfold k z + where + k c = ID (unID c f) + z = ID + + +-- | Monadic variation on 'fromConstrB' +fromConstrM :: (Monad m, Data a) + => (forall d. Data d => m d) + -> Constr + -> m a +fromConstrM f = gunfold k z + where + k c = do { c' <- c; b <- f; return (c' b) } + z = return + + + +------------------------------------------------------------------------------ +-- +-- Datatype and constructor representations +-- +------------------------------------------------------------------------------ + + +-- +-- | Representation of datatypes. +-- A package of constructor representations with names of type and module. +-- +data DataType = DataType + { tycon :: String + , datarep :: DataRep + } + + deriving Show + + +-- | Representation of constructors +data Constr = Constr + { conrep :: ConstrRep + , constring :: String + , confields :: [String] -- for AlgRep only + , confixity :: Fixity -- for AlgRep only + , datatype :: DataType + } + +instance Show Constr where + show = constring + + +-- | Equality of constructors +instance Eq Constr where + c == c' = constrRep c == constrRep c' + + +-- | Public representation of datatypes +data DataRep = AlgRep [Constr] + | IntRep + | FloatRep + | StringRep + | NoRep + + deriving (Eq,Show) +-- The list of constructors could be an array, a balanced tree, or others. + + +-- | Public representation of constructors +data ConstrRep = AlgConstr ConIndex + | IntConstr Integer + | FloatConstr Double + | StringConstr String + + deriving (Eq,Show) + + +-- | Unique index for datatype constructors, +-- counting from 1 in the order they are given in the program text. +type ConIndex = Int + + +-- | Fixity of constructors +data Fixity = Prefix + | Infix -- Later: add associativity and precedence + + deriving (Eq,Show) + + +------------------------------------------------------------------------------ +-- +-- Observers for datatype representations +-- +------------------------------------------------------------------------------ + + +-- | Gets the type constructor including the module +dataTypeName :: DataType -> String +dataTypeName = tycon + + + +-- | Gets the public presentation of a datatype +dataTypeRep :: DataType -> DataRep +dataTypeRep = datarep + + +-- | Gets the datatype of a constructor +constrType :: Constr -> DataType +constrType = datatype + + +-- | Gets the public presentation of constructors +constrRep :: Constr -> ConstrRep +constrRep = conrep + + +-- | Look up a constructor by its representation +repConstr :: DataType -> ConstrRep -> Constr +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 + _ -> error "repConstr" + + + +------------------------------------------------------------------------------ +-- +-- Representations of algebraic data types +-- +------------------------------------------------------------------------------ + + +-- | Constructs an algebraic datatype +mkDataType :: String -> [Constr] -> DataType +mkDataType str cs = DataType + { tycon = str + , datarep = AlgRep cs + } + + +-- | Constructs a constructor +mkConstr :: DataType -> String -> [String] -> Fixity -> Constr +mkConstr dt str fields fix = + Constr + { conrep = AlgConstr idx + , constring = str + , confields = fields + , confixity = fix + , datatype = dt + } + where + idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..], + showConstr c == str ] + + +-- | Gets the constructors of an algebraic datatype +dataTypeConstrs :: DataType -> [Constr] +dataTypeConstrs dt = case datarep dt of + (AlgRep cons) -> cons + _ -> error "dataTypeConstrs" + + +-- | Gets the field labels of a constructor. The list of labels +-- is returned in the same order as they were given in the original +-- constructor declaration. +constrFields :: Constr -> [String] +constrFields = confields + + +-- | Gets the fixity of a constructor +constrFixity :: Constr -> Fixity +constrFixity = confixity + + + +------------------------------------------------------------------------------ +-- +-- From strings to constr's and vice versa: all data types +-- +------------------------------------------------------------------------------ + + +-- | Gets the string for a constructor +showConstr :: Constr -> String +showConstr = constring + + +-- | Lookup a constructor via a string +readConstr :: DataType -> String -> Maybe Constr +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) + NoRep -> Nothing + where + + -- Read a value and build a constructor + mkReadCon :: Read t => (t -> Constr) -> Maybe Constr + mkReadCon f = case (reads str) of + [(t,"")] -> Just (f t) + _ -> Nothing + + -- Traverse list of algebraic datatype constructors + idx :: [Constr] -> Maybe Constr + idx cons = let fit = filter ((==) str . showConstr) cons + in if fit == [] + then Nothing + else Just (head fit) + + +------------------------------------------------------------------------------ +-- +-- Convenience funtions: algebraic data types +-- +------------------------------------------------------------------------------ + + +-- | Test for an algebraic type +isAlgType :: DataType -> Bool +isAlgType dt = case datarep dt of + (AlgRep _) -> True + _ -> False + + +-- | Gets the constructor for an index (algebraic datatypes only) +indexConstr :: DataType -> ConIndex -> Constr +indexConstr dt idx = case datarep dt of + (AlgRep cs) -> cs !! (idx-1) + _ -> error "indexConstr" + + +-- | Gets the index of a constructor (algebraic datatypes only) +constrIndex :: Constr -> ConIndex +constrIndex con = case constrRep con of + (AlgConstr idx) -> idx + _ -> error "constrIndex" + + +-- | Gets the maximum constructor index of an algebraic datatype +maxConstrIndex :: DataType -> ConIndex +maxConstrIndex dt = case dataTypeRep dt of + AlgRep cs -> length cs + _ -> error "maxConstrIndex" + + + +------------------------------------------------------------------------------ +-- +-- Representation of primitive types +-- +------------------------------------------------------------------------------ + + +-- | Constructs the 'Int' type +mkIntType :: String -> DataType +mkIntType = mkPrimType IntRep + + +-- | Constructs the 'Float' type +mkFloatType :: String -> DataType +mkFloatType = mkPrimType FloatRep + + +-- | Constructs the 'String' type +mkStringType :: String -> DataType +mkStringType = mkPrimType StringRep + + +-- | Helper for 'mkIntType', 'mkFloatType', 'mkStringType' +mkPrimType :: DataRep -> String -> DataType +mkPrimType dr str = DataType + { tycon = str + , datarep = dr + } + + +-- Makes a constructor for primitive types +mkPrimCon :: DataType -> String -> ConstrRep -> Constr +mkPrimCon dt str cr = Constr + { datatype = dt + , conrep = cr + , constring = str + , confields = error "constrFields" + , confixity = error "constrFixity" + } + + +mkIntConstr :: DataType -> Integer -> Constr +mkIntConstr dt i = case datarep dt of + IntRep -> mkPrimCon dt (show i) (IntConstr i) + _ -> error "mkIntConstr" + + +mkFloatConstr :: DataType -> Double -> Constr +mkFloatConstr dt f = case datarep dt of + FloatRep -> mkPrimCon dt (show f) (FloatConstr f) + _ -> error "mkFloatConstr" + + +mkStringConstr :: DataType -> String -> Constr +mkStringConstr dt str = case datarep dt of + StringRep -> mkPrimCon dt str (StringConstr str) + _ -> error "mkStringConstr" + + +------------------------------------------------------------------------------ +-- +-- Non-representations for non-presentable types +-- +------------------------------------------------------------------------------ + + +-- | 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 +isNorepType dt = case datarep dt of + NoRep -> True + _ -> False + + + +------------------------------------------------------------------------------ +-- +-- Convenience for qualified type constructors +-- +------------------------------------------------------------------------------ + + +-- | Gets the unqualified type constructor: +-- drop *.*.*... before name +-- +tyconUQname :: String -> String +tyconUQname x = let x' = dropWhile (not . (==) '.') x + in if x' == [] then x else tyconUQname (tail x') + + +-- | Gets the module of a type constructor: +-- take *.*.*... before name +tyconModule :: String -> String +tyconModule x = let (a,b) = break ((==) '.') x + in if b == "" + then b + else a ++ tyconModule' (tail b) + where + tyconModule' y = let y' = tyconModule y + in if y' == "" then "" else ('.':y') + + + + +------------------------------------------------------------------------------ +------------------------------------------------------------------------------ +-- +-- Instances of the Data class for Prelude-like types. +-- We define top-level definitions for representations. +-- +------------------------------------------------------------------------------ + + +falseConstr :: Constr +falseConstr = mkConstr boolDataType "False" [] Prefix +trueConstr :: Constr +trueConstr = mkConstr boolDataType "True" [] Prefix + +boolDataType :: DataType +boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr] + +instance Data Bool where + toConstr False = falseConstr + toConstr True = trueConstr + gunfold _ z c = case constrIndex c of + 1 -> z False + 2 -> z True + _ -> error "gunfold" + dataTypeOf _ = boolDataType + + +------------------------------------------------------------------------------ + +charType :: DataType +charType = mkStringType "Prelude.Char" + +instance Data Char where + toConstr x = mkStringConstr charType [x] + gunfold _ z c = case constrRep c of + (StringConstr [x]) -> z x + _ -> error "gunfold" + dataTypeOf _ = charType + + +------------------------------------------------------------------------------ + +floatType :: DataType +floatType = mkFloatType "Prelude.Float" + +instance Data Float where + toConstr x = mkFloatConstr floatType (realToFrac x) + gunfold _ z c = case constrRep c of + (FloatConstr x) -> z (realToFrac x) + _ -> error "gunfold" + dataTypeOf _ = floatType + + +------------------------------------------------------------------------------ + +doubleType :: DataType +doubleType = mkFloatType "Prelude.Double" + +instance Data Double where + toConstr = mkFloatConstr floatType + gunfold _ z c = case constrRep c of + (FloatConstr x) -> z x + _ -> error "gunfold" + dataTypeOf _ = doubleType + + +------------------------------------------------------------------------------ + +intType :: DataType +intType = mkIntType "Prelude.Int" + +instance Data Int where + toConstr x = mkIntConstr intType (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = intType + + +------------------------------------------------------------------------------ + +integerType :: DataType +integerType = mkIntType "Prelude.Integer" + +instance Data Integer where + toConstr = mkIntConstr integerType + gunfold _ z c = case constrRep c of + (IntConstr x) -> z x + _ -> error "gunfold" + dataTypeOf _ = integerType + + +------------------------------------------------------------------------------ + +int8Type :: DataType +int8Type = mkIntType "Data.Int.Int8" + +instance Data Int8 where + toConstr x = mkIntConstr int8Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int8Type + + +------------------------------------------------------------------------------ + +int16Type :: DataType +int16Type = mkIntType "Data.Int.Int16" + +instance Data Int16 where + toConstr x = mkIntConstr int16Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int16Type + + +------------------------------------------------------------------------------ + +int32Type :: DataType +int32Type = mkIntType "Data.Int.Int32" + +instance Data Int32 where + toConstr x = mkIntConstr int32Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int32Type + + +------------------------------------------------------------------------------ + +int64Type :: DataType +int64Type = mkIntType "Data.Int.Int64" + +instance Data Int64 where + toConstr x = mkIntConstr int64Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = int64Type + + +------------------------------------------------------------------------------ + +wordType :: DataType +wordType = mkIntType "Data.Word.Word" + +instance Data Word where + toConstr x = mkIntConstr wordType (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = wordType + + +------------------------------------------------------------------------------ + +word8Type :: DataType +word8Type = mkIntType "Data.Word.Word8" + +instance Data Word8 where + toConstr x = mkIntConstr word8Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word8Type + + +------------------------------------------------------------------------------ + +word16Type :: DataType +word16Type = mkIntType "Data.Word.Word16" + +instance Data Word16 where + toConstr x = mkIntConstr word16Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word16Type + + +------------------------------------------------------------------------------ + +word32Type :: DataType +word32Type = mkIntType "Data.Word.Word32" + +instance Data Word32 where + toConstr x = mkIntConstr word32Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word32Type + + +------------------------------------------------------------------------------ + +word64Type :: DataType +word64Type = mkIntType "Data.Word.Word64" + +instance Data Word64 where + toConstr x = mkIntConstr word64Type (fromIntegral x) + gunfold _ z c = case constrRep c of + (IntConstr x) -> z (fromIntegral x) + _ -> error "gunfold" + dataTypeOf _ = word64Type + + +------------------------------------------------------------------------------ + +ratioConstr :: Constr +ratioConstr = mkConstr ratioDataType ":%" [] Infix + +ratioDataType :: DataType +ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr] + +instance (Data a, Integral a) => Data (Ratio a) where + gfoldl k z (a :% b) = z (:%) `k` a `k` b + toConstr _ = ratioConstr + gunfold k z c | constrIndex c == 1 = k (k (z (:%))) + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = ratioDataType + + +------------------------------------------------------------------------------ + +nilConstr :: Constr +nilConstr = mkConstr listDataType "[]" [] Prefix +consConstr :: Constr +consConstr = mkConstr listDataType "(:)" [] Infix + +listDataType :: DataType +listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr] + +instance Data a => Data [a] where + gfoldl _ z [] = z [] + gfoldl f z (x:xs) = z (:) `f` x `f` xs + toConstr [] = nilConstr + toConstr (_:_) = consConstr + gunfold k z c = case constrIndex c of + 1 -> z [] + 2 -> k (k (z (:))) + _ -> error "gunfold" + dataTypeOf _ = listDataType + dataCast1 f = gcast1 f + +-- +-- The gmaps are given as an illustration. +-- This shows that the gmaps for lists are different from list maps. +-- + gmapT _ [] = [] + gmapT f (x:xs) = (f x:f xs) + gmapQ _ [] = [] + gmapQ f (x:xs) = [f x,f xs] + gmapM _ [] = return [] + gmapM f (x:xs) = f x >>= \x' -> f xs >>= \xs' -> return (x':xs') + + +------------------------------------------------------------------------------ + +nothingConstr :: Constr +nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix +justConstr :: Constr +justConstr = mkConstr maybeDataType "Just" [] Prefix + +maybeDataType :: DataType +maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr] + +instance Data a => Data (Maybe a) where + gfoldl _ z Nothing = z Nothing + gfoldl f z (Just x) = z Just `f` x + toConstr Nothing = nothingConstr + toConstr (Just _) = justConstr + gunfold k z c = case constrIndex c of + 1 -> z Nothing + 2 -> k (z Just) + _ -> error "gunfold" + dataTypeOf _ = maybeDataType + dataCast1 f = gcast1 f + + +------------------------------------------------------------------------------ + +ltConstr :: Constr +ltConstr = mkConstr orderingDataType "LT" [] Prefix +eqConstr :: Constr +eqConstr = mkConstr orderingDataType "EQ" [] Prefix +gtConstr :: Constr +gtConstr = mkConstr orderingDataType "GT" [] Prefix + +orderingDataType :: DataType +orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr] + +instance Data Ordering where + gfoldl _ z LT = z LT + gfoldl _ z EQ = z EQ + gfoldl _ z GT = z GT + toConstr LT = ltConstr + toConstr EQ = eqConstr + toConstr GT = gtConstr + gunfold _ z c = case constrIndex c of + 1 -> z LT + 2 -> z EQ + 3 -> z GT + _ -> error "gunfold" + dataTypeOf _ = orderingDataType + + +------------------------------------------------------------------------------ + +leftConstr :: Constr +leftConstr = mkConstr eitherDataType "Left" [] Prefix + +rightConstr :: Constr +rightConstr = mkConstr eitherDataType "Right" [] Prefix + +eitherDataType :: DataType +eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr] + +instance (Data a, Data b) => Data (Either a b) where + gfoldl f z (Left a) = z Left `f` a + gfoldl f z (Right a) = z Right `f` a + toConstr (Left _) = leftConstr + toConstr (Right _) = rightConstr + gunfold k z c = case constrIndex c of + 1 -> k (z Left) + 2 -> k (z Right) + _ -> error "gunfold" + dataTypeOf _ = eitherDataType + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + + +-- +-- A last resort for functions +-- + +instance (Data a, Data b) => Data (a -> b) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNorepType "Prelude.(->)" + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + +tuple0Constr :: Constr +tuple0Constr = mkConstr tuple0DataType "()" [] Prefix + +tuple0DataType :: DataType +tuple0DataType = mkDataType "Prelude.()" [tuple0Constr] + +instance Data () where + toConstr () = tuple0Constr + gunfold _ z c | constrIndex c == 1 = z () + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = tuple0DataType + + +------------------------------------------------------------------------------ + +tuple2Constr :: Constr +tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix + +tuple2DataType :: DataType +tuple2DataType = mkDataType "Prelude.(,)" [tuple2Constr] + +instance (Data a, Data b) => Data (a,b) where + gfoldl f z (a,b) = z (,) `f` a `f` b + toConstr (_,_) = tuple2Constr + gunfold k z c | constrIndex c == 1 = k (k (z (,))) + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = tuple2DataType + dataCast2 f = gcast2 f + + +------------------------------------------------------------------------------ + +tuple3Constr :: Constr +tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix + +tuple3DataType :: DataType +tuple3DataType = mkDataType "Prelude.(,)" [tuple3Constr] + +instance (Data a, Data b, Data c) => Data (a,b,c) where + gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c + toConstr (_,_,_) = tuple3Constr + gunfold k z c | constrIndex c == 1 = k (k (k (z (,,)))) + gunfold _ _ _ = error "gunfold" + dataTypeOf _ = tuple3DataType + + +------------------------------------------------------------------------------ + +tuple4Constr :: Constr +tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix + +tuple4DataType :: DataType +tuple4DataType = mkDataType "Prelude.(,,,)" [tuple4Constr] + +instance (Data a, Data b, Data c, Data d) + => Data (a,b,c,d) where + gfoldl f z (a,b,c,d) = z (,,,) `f` a `f` b `f` c `f` d + toConstr (_,_,_,_) = tuple4Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (z (,,,))))) + _ -> error "gunfold" + dataTypeOf _ = tuple4DataType + + +------------------------------------------------------------------------------ + +tuple5Constr :: Constr +tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix + +tuple5DataType :: DataType +tuple5DataType = mkDataType "Prelude.(,,,,)" [tuple5Constr] + +instance (Data a, Data b, Data c, Data d, Data e) + => Data (a,b,c,d,e) where + gfoldl f z (a,b,c,d,e) = z (,,,,) `f` a `f` b `f` c `f` d `f` e + toConstr (_,_,_,_,_) = tuple5Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (z (,,,,)))))) + _ -> error "gunfold" + dataTypeOf _ = tuple5DataType + + +------------------------------------------------------------------------------ + +tuple6Constr :: Constr +tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix + +tuple6DataType :: DataType +tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr] + +instance (Data a, Data b, Data c, Data d, Data e, Data f) + => Data (a,b,c,d,e,f) where + gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' + toConstr (_,_,_,_,_,_) = tuple6Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (k (z (,,,,,))))))) + _ -> error "gunfold" + dataTypeOf _ = tuple6DataType + + +------------------------------------------------------------------------------ + +tuple7Constr :: Constr +tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix + +tuple7DataType :: DataType +tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr] + +instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g) + => Data (a,b,c,d,e,f,g) where + gfoldl f z (a,b,c,d,e,f',g) = + z (,,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f' `f` g + toConstr (_,_,_,_,_,_,_) = tuple7Constr + gunfold k z c = case constrIndex c of + 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) + _ -> error "gunfold" + dataTypeOf _ = tuple7DataType + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (Ptr a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNorepType "GHC.Ptr.Ptr" + + +------------------------------------------------------------------------------ + +instance Typeable a => Data (ForeignPtr a) where + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNorepType "GHC.ForeignPtr.ForeignPtr" + + +------------------------------------------------------------------------------ +-- The Data instance for Array preserves data abstraction at the cost of +-- inefficiency. We omit reflection services for the sake of data abstraction. +instance (Typeable a, Data b, Ix a) => Data (Array a b) + where + gfoldl f z a = z (listArray (bounds a)) `f` (elems a) + toConstr _ = error "toConstr" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNorepType "Data.Array.Array" + -- 1.7.10.4