-----------------------------------------------------------------------------
-- |
-- Module : Data.Generics
--- Copyright : (c) The University of Glasgow, CWI 2001--2003
+-- Copyright : (c) The University of Glasgow, CWI 2001--2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
module Data.Generics.Schemes, -- traversal schemes (everywhere etc.)
module Data.Generics.Text, -- generic read and show
module Data.Generics.Twins, -- twin traversal, e.g., generic eq
- module Data.Generics.Reify, -- experimental reification theme
#ifndef __HADDOCK__
,
import Data.Generics.Schemes
import Data.Generics.Text
import Data.Generics.Twins
-import Data.Generics.Reify
-- * Combinators to \"make\" generic functions via cast
mkT, mkQ, mkM, mkMp, mkR,
- extT, extQ, extM, extMp, extB, extR,
+ ext0, extT, extQ, extM, extMp, extB, extR,
-- * Type synonyms for generic function types
GenericT,
=> (b -> b)
-> a
-> a
-mkT f = case cast f of
- Just g -> g
- Nothing -> id
+mkT = extT id
-- | Make a generic query;
-- | Flexible type extension
ext0 :: (Typeable a, Typeable b) => c a -> c b -> c a
-ext0 def ext = maybe def id (cast0 ext)
+ext0 def ext = maybe def id (gcast ext)
-- | Extend a generic transformation by a type-specific case
extT :: ( Typeable a
- , Typeable b
+ , Typeable b
)
=> (a -> a)
-> (b -> b)
-> a
-> a
-extT f = maybe f id . cast
+extT def ext = unT ((T def) `ext0` (T ext))
-- | Extend a generic query by a type-specific case
=> c a
-> (forall a. Data a => c (t a))
-> c a
-ext1 def ext = maybe def id (cast0to1 ext)
+ext1 def ext = maybe def id (dataCast1 ext)
-- | Type extension of transformations for unary type constructors
module Data.Generics.Basics (
- -- Module Data.Typeable re-exported for convenience
+ -- * Module Data.Typeable re-exported for convenience
module Data.Typeable,
-- * The Data class for processing constructor applications
toConstr, -- :: a -> Constr
fromConstr, -- :: Constr -> a
dataTypeOf, -- :: a -> DataType
- cast0to1, -- mediate types and unary type constructors
- cast0to2 -- mediate types and binary type constructors
+ dataCast1, -- mediate types and unary type constructors
+ dataCast2 -- mediate types and binary type constructors
),
-- * Datatype representations
DataType, -- abstract, instance of: Show
Constr, -- abstract, instance of: Eq, Show
DataRep(..), -- instance of: Eq, Show
- ConRep(..), -- instance of: Eq, Show
+ ConstrRep(..), -- instance of: Eq, Show
ConIndex, -- alias for Int, start at 1
Fixity(..), -- instance of: Eq, Show
-- * Observers for datatype representations
- dataTypeCon, -- :: DataType -> String
+ dataTypeName, -- :: DataType -> String
dataTypeRep, -- :: DataType -> DataRep
- conDataType, -- :: Constr -> DataType
- conRep, -- :: Constr -> ConRep
- repCon, -- :: DataType -> ConRep -> Constr
+ constrType, -- :: Constr -> DataType
+ constrRep, -- :: Constr -> ConstrRep
+ repConstr, -- :: DataType -> ConstrRep -> Constr
-- * Representations of algebraic data types
- mkDataType, -- :: String -> [Constr] -> DataType
- mkDataCon, -- :: DataType -> String -> Fixity -> Constr
- algTypeCons, -- :: DataType -> [Constr]
- conFixity, -- :: Constr -> Fixity
+ mkDataType, -- :: String -> [Constr] -> DataType
+ mkConstr, -- :: DataType -> String -> Fixity -> Constr
+ dataTypeConstrs,-- :: DataType -> [Constr]
+ constrFields, -- :: Constr -> [String]
+ constrFixity, -- :: Constr -> Fixity
-- * From strings to constr's and vice versa: all data types
- conString, -- :: Constr -> String
- stringCon, -- :: DataType -> String -> Maybe Constr
+ showConstr, -- :: Constr -> String
+ readConstr, -- :: DataType -> String -> Maybe Constr
-- * Convenience funtions: algebraic data types
isAlgType, -- :: DataType -> Bool
- indexCon, -- :: DataType -> ConIndex -> Constr
- conIndex, -- :: Constr -> ConIndex
- maxConIndex, -- :: DataType -> ConIndex
+ indexConstr, -- :: DataType -> ConIndex -> Constr
+ constrIndex, -- :: Constr -> ConIndex
+ maxConstrIndex, -- :: DataType -> ConIndex
-- * Representation of primitive types
mkIntType, -- :: String -> DataType
mkFloatType, -- :: String -> DataType
mkStringType, -- :: String -> DataType
- mkIntCon, -- :: DataType -> Integer -> Constr
- mkFloatCon, -- :: DataType -> Double -> Constr
- mkStringCon, -- :: DataType -> String -> Constr
+ mkIntConstr, -- :: DataType -> Integer -> Constr
+ mkFloatConstr, -- :: DataType -> Double -> Constr
+ mkStringConstr, -- :: DataType -> String -> Constr
-- * Non-representations for non-presentable types
mkNorepType, -- :: String -> DataType
------------------------------------------------------------------------------
-- | Mediate types and unary type constructors
- cast0to1 :: Typeable1 t
- => (forall a. Data a => c (t a))
- -> Maybe (c a)
- cast0to1 _ = Nothing
+ dataCast1 :: Typeable1 t
+ => (forall a. Data a => c (t a))
+ -> Maybe (c a)
+ dataCast1 _ = Nothing
-- | Mediate types and binary type constructors
- cast0to2 :: Typeable2 t
- => (forall a b. (Data a, Data b) => c (t a b))
- -> Maybe (c a)
- cast0to2 _ = Nothing
+ dataCast2 :: Typeable2 t
+ => (forall a b. (Data a, Data b) => c (t a b))
+ -> Maybe (c a)
+ dataCast2 _ = Nothing
-- | Representation of constructors
data Constr = Constr
- { conrep :: ConRep
+ { conrep :: ConstrRep
, constring :: String
+ , confields :: [String] -- for AlgRep only
, confixity :: Fixity -- for AlgRep only
, datatype :: DataType
}
-- | Equality of constructors
instance Eq Constr where
- c == c' = conRep c == conRep c'
+ c == c' = constrRep c == constrRep c'
-- | Public representation of datatypes
-- | Public representation of constructors
-data ConRep = AlgCon ConIndex
- | IntCon Integer
- | FloatCon Double
- | StringCon String
+data ConstrRep = AlgConstr ConIndex
+ | IntConstr Integer
+ | FloatConstr Double
+ | StringConstr String
- deriving (Eq,Show)
+ deriving (Eq,Show)
--
-- | Gets the type constructor including the module
-dataTypeCon :: DataType -> String
-dataTypeCon = tycon
+dataTypeName :: DataType -> String
+dataTypeName = tycon
-- | Gets the datatype of a constructor
-conDataType :: Constr -> DataType
-conDataType = datatype
+constrType :: Constr -> DataType
+constrType = datatype
-- | Gets the public presentation of constructors
-conRep :: Constr -> ConRep
-conRep = conrep
+constrRep :: Constr -> ConstrRep
+constrRep = conrep
-- | Look up a constructor by its representation
-repCon :: DataType -> ConRep -> Constr
-repCon dt cr =
+repConstr :: DataType -> ConstrRep -> Constr
+repConstr dt cr =
case (dataTypeRep dt, cr) of
- (AlgRep cs, AlgCon i) -> cs !! (i-1)
- (IntRep, IntCon i) -> mkIntCon dt i
- (FloatRep, FloatCon f) -> mkFloatCon dt f
- (StringRep, StringCon str) -> mkStringCon dt str
- _ -> error "repCon"
+ (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"
-- | Constructs a constructor
-mkDataCon :: DataType -> String -> Fixity -> Constr
-mkDataCon dt str fix =
+mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
+mkConstr dt str fields fix =
Constr
- { conrep = AlgCon idx
+ { conrep = AlgConstr idx
, constring = str
+ , confields = fields
, confixity = fix
, datatype = dt
}
where
- idx = head [ i | (c,i) <- algTypeCons dt `zip` [1..],
- conString c == str ]
+ idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
+ showConstr c == str ]
-- | Gets the constructors
-algTypeCons :: DataType -> [Constr]
-algTypeCons dt = case datarep dt of
- (AlgRep cons) -> cons
- _ -> error "algTypeCons"
+dataTypeConstrs :: DataType -> [Constr]
+dataTypeConstrs dt = case datarep dt of
+ (AlgRep cons) -> cons
+ _ -> error "dataTypeConstrs"
+
+
+-- | Gets the field labels of a constructor
+constrFields :: Constr -> [String]
+constrFields = confields
-- | Gets the fixity of a constructor
-conFixity :: Constr -> Fixity
-conFixity = confixity
+constrFixity :: Constr -> Fixity
+constrFixity = confixity
-- | Gets the string for a constructor
-conString :: Constr -> String
-conString = constring
+showConstr :: Constr -> String
+showConstr = constring
-- | Lookup a constructor via a string
-stringCon :: DataType -> String -> Maybe Constr
-stringCon dt str =
+readConstr :: DataType -> String -> Maybe Constr
+readConstr dt str =
case dataTypeRep dt of
AlgRep cons -> idx cons
- IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntCon i)))
- FloatRep -> mkReadCon (\f -> (mkPrimCon dt str (FloatCon f)))
- StringRep -> Just (mkStringCon dt str)
+ IntRep -> mkReadCon (\i -> (mkPrimCon dt str (IntConstr i)))
+ FloatRep -> mkReadCon (\f -> (mkPrimCon dt str (FloatConstr f)))
+ StringRep -> Just (mkStringConstr dt str)
NoRep -> Nothing
where
-- Traverse list of algebraic datatype constructors
idx :: [Constr] -> Maybe Constr
- idx cons = let fit = filter ((==) str . conString) cons
+ idx cons = let fit = filter ((==) str . showConstr) cons
in if fit == []
then Nothing
else Just (head fit)
-- | Gets the constructor for an index
-indexCon :: DataType -> ConIndex -> Constr
-indexCon dt idx = case datarep dt of
- (AlgRep cs) -> cs !! (idx-1)
- _ -> error "indexCon"
+indexConstr :: DataType -> ConIndex -> Constr
+indexConstr dt idx = case datarep dt of
+ (AlgRep cs) -> cs !! (idx-1)
+ _ -> error "indexConstr"
-- | Gets the index of a constructor
-conIndex :: Constr -> ConIndex
-conIndex con = case conRep con of
- (AlgCon idx) -> idx
- _ -> error "conIndex"
+constrIndex :: Constr -> ConIndex
+constrIndex con = case constrRep con of
+ (AlgConstr idx) -> idx
+ _ -> error "constrIndex"
-- | Gets the maximum constructor index
-maxConIndex :: DataType -> ConIndex
-maxConIndex dt = case dataTypeRep dt of
- AlgRep cs -> length cs
- _ -> error "maxConIndex"
+maxConstrIndex :: DataType -> ConIndex
+maxConstrIndex dt = case dataTypeRep dt of
+ AlgRep cs -> length cs
+ _ -> error "maxConstrIndex"
-- Makes a constructor for primitive types
-mkPrimCon :: DataType -> String -> ConRep -> Constr
+mkPrimCon :: DataType -> String -> ConstrRep -> Constr
mkPrimCon dt str cr = Constr
{ datatype = dt
, conrep = cr
, constring = str
- , confixity = error "conFixity"
+ , confields = error "constrFields"
+ , confixity = error "constrFixity"
}
-mkIntCon :: DataType -> Integer -> Constr
-mkIntCon dt i = case datarep dt of
- IntRep -> mkPrimCon dt (show i) (IntCon i)
- _ -> error "mkIntCon"
+mkIntConstr :: DataType -> Integer -> Constr
+mkIntConstr dt i = case datarep dt of
+ IntRep -> mkPrimCon dt (show i) (IntConstr i)
+ _ -> error "mkIntConstr"
-mkFloatCon :: DataType -> Double -> Constr
-mkFloatCon dt f = case datarep dt of
- FloatRep -> mkPrimCon dt (show f) (FloatCon f)
- _ -> error "mkFloatCon"
+mkFloatConstr :: DataType -> Double -> Constr
+mkFloatConstr dt f = case datarep dt of
+ FloatRep -> mkPrimCon dt (show f) (FloatConstr f)
+ _ -> error "mkFloatConstr"
-mkStringCon :: DataType -> String -> Constr
-mkStringCon dt str = case datarep dt of
- StringRep -> mkPrimCon dt str (StringCon str)
- _ -> error "mkStringCon"
+mkStringConstr :: DataType -> String -> Constr
+mkStringConstr dt str = case datarep dt of
+ StringRep -> mkPrimCon dt str (StringConstr str)
+ _ -> error "mkStringConstr"
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-falseConstr = mkDataCon boolDataType "False" Prefix
-trueConstr = mkDataCon boolDataType "True" Prefix
+falseConstr = mkConstr boolDataType "False" [] Prefix
+trueConstr = mkConstr boolDataType "True" [] Prefix
boolDataType = mkDataType "Prelude.Bool" [falseConstr,trueConstr]
instance Data Bool where
toConstr False = falseConstr
toConstr True = trueConstr
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> False
2 -> True
_ -> error "fromConstr"
charType = mkStringType "Prelude.Char"
instance Data Char where
- toConstr x = mkStringCon charType [x]
- fromConstr con = case conRep con of
- (StringCon [x]) -> x
+ toConstr x = mkStringConstr charType [x]
+ fromConstr con = case constrRep con of
+ (StringConstr [x]) -> x
_ -> error "fromConstr"
dataTypeOf _ = charType
floatType = mkFloatType "Prelude.Float"
instance Data Float where
- toConstr x = mkFloatCon floatType (realToFrac x)
- fromConstr con = case conRep con of
- (FloatCon x) -> realToFrac x
+ toConstr x = mkFloatConstr floatType (realToFrac x)
+ fromConstr con = case constrRep con of
+ (FloatConstr x) -> realToFrac x
_ -> error "fromConstr"
dataTypeOf _ = floatType
doubleType = mkFloatType "Prelude.Double"
instance Data Double where
- toConstr = mkFloatCon floatType
- fromConstr con = case conRep con of
- (FloatCon x) -> x
+ toConstr = mkFloatConstr floatType
+ fromConstr con = case constrRep con of
+ (FloatConstr x) -> x
_ -> error "fromConstr"
dataTypeOf _ = doubleType
intType = mkIntType "Prelude.Int"
instance Data Int where
- toConstr x = mkIntCon intType (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr intType (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = intType
integerType = mkIntType "Prelude.Integer"
instance Data Integer where
- toConstr = mkIntCon integerType
- fromConstr con = case conRep con of
- (IntCon x) -> x
+ toConstr = mkIntConstr integerType
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> x
_ -> error "fromConstr"
dataTypeOf _ = integerType
int8Type = mkIntType "Data.Int.Int8"
instance Data Int8 where
- toConstr x = mkIntCon int8Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr int8Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = int8Type
int16Type = mkIntType "Data.Int.Int16"
instance Data Int16 where
- toConstr x = mkIntCon int16Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr int16Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = int16Type
int32Type = mkIntType "Data.Int.Int32"
instance Data Int32 where
- toConstr x = mkIntCon int32Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr int32Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = int32Type
int64Type = mkIntType "Data.Int.Int64"
instance Data Int64 where
- toConstr x = mkIntCon int64Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr int64Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = int64Type
wordType = mkIntType "Data.Word.Word"
instance Data Word where
- toConstr x = mkIntCon wordType (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr wordType (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = wordType
word8Type = mkIntType "Data.Word.Word8"
instance Data Word8 where
- toConstr x = mkIntCon word8Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr word8Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = word8Type
word16Type = mkIntType "Data.Word.Word16"
instance Data Word16 where
- toConstr x = mkIntCon word16Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr word16Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = word16Type
word32Type = mkIntType "Data.Word.Word32"
instance Data Word32 where
- toConstr x = mkIntCon word32Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr word32Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = word32Type
word64Type = mkIntType "Data.Word.Word64"
instance Data Word64 where
- toConstr x = mkIntCon word64Type (fromIntegral x)
- fromConstr con = case conRep con of
- (IntCon x) -> fromIntegral x
+ toConstr x = mkIntConstr word64Type (fromIntegral x)
+ fromConstr con = case constrRep con of
+ (IntConstr x) -> fromIntegral x
_ -> error "fromConstr"
dataTypeOf _ = word64Type
------------------------------------------------------------------------------
-ratioConstr = mkDataCon ratioDataType ":%" Infix
+ratioConstr = mkConstr ratioDataType ":%" [] Infix
ratioDataType = mkDataType "GHC.Real.Ratio" [ratioConstr]
instance (Data a, Integral a) => Data (Ratio a) where
toConstr _ = ratioConstr
- fromConstr c | conIndex c == 1 = undefined :% undefined
+ fromConstr c | constrIndex c == 1 = undefined :% undefined
fromConstr _ = error "fromConstr"
dataTypeOf _ = ratioDataType
------------------------------------------------------------------------------
-nilConstr = mkDataCon listDataType "[]" Prefix
-consConstr = mkDataCon listDataType "(:)" Infix
+nilConstr = mkConstr listDataType "[]" [] Prefix
+consConstr = mkConstr listDataType "(:)" [] Infix
listDataType = mkDataType "Prelude.[]" [nilConstr,consConstr]
instance Data a => Data [a] where
gfoldl f z (x:xs) = z (:) `f` x `f` xs
toConstr [] = nilConstr
toConstr (_:_) = consConstr
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> []
2 -> undefined:undefined
_ -> error "fromConstr"
dataTypeOf _ = listDataType
- cast0to1 = cast1
+ dataCast1 = gcast1
--
-- The gmaps are given as an illustration.
------------------------------------------------------------------------------
-nothingConstr = mkDataCon maybeDataType "Nothing" Prefix
-justConstr = mkDataCon maybeDataType "Just" Prefix
+nothingConstr = mkConstr maybeDataType "Nothing" [] Prefix
+justConstr = mkConstr maybeDataType "Just" [] Prefix
maybeDataType = mkDataType "Prelude.Maybe" [nothingConstr,justConstr]
instance Data a => Data (Maybe a) where
gfoldl f z (Just x) = z Just `f` x
toConstr Nothing = nothingConstr
toConstr (Just _) = justConstr
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> Nothing
2 -> Just undefined
_ -> error "fromConstr"
dataTypeOf _ = maybeDataType
- cast0to1 = cast1
+ dataCast1 = gcast1
------------------------------------------------------------------------------
-ltConstr = mkDataCon orderingDataType "LT" Prefix
-eqConstr = mkDataCon orderingDataType "EQ" Prefix
-gtConstr = mkDataCon orderingDataType "GT" Prefix
+ltConstr = mkConstr orderingDataType "LT" [] Prefix
+eqConstr = mkConstr orderingDataType "EQ" [] Prefix
+gtConstr = mkConstr orderingDataType "GT" [] Prefix
orderingDataType = mkDataType "Prelude.Ordering" [ltConstr,eqConstr,gtConstr]
instance Data Ordering where
toConstr LT = ltConstr
toConstr EQ = eqConstr
toConstr GT = gtConstr
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> LT
2 -> EQ
3 -> GT
------------------------------------------------------------------------------
-leftConstr = mkDataCon eitherDataType "Left" Prefix
-rightConstr = mkDataCon eitherDataType "Right" Prefix
+leftConstr = mkConstr eitherDataType "Left" [] Prefix
+rightConstr = mkConstr eitherDataType "Right" [] Prefix
eitherDataType = mkDataType "Prelude.Either" [leftConstr,rightConstr]
instance (Data a, Data b) => Data (Either a b) where
gfoldl f z (Right a) = z Right `f` a
toConstr (Left _) = leftConstr
toConstr (Right _) = rightConstr
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> Left undefined
2 -> Right undefined
_ -> error "fromConstr"
dataTypeOf _ = eitherDataType
- cast0to2 = cast2
+ dataCast2 = gcast2
------------------------------------------------------------------------------
toConstr _ = error "toConstr"
fromConstr _ = error "fromConstr"
dataTypeOf _ = mkNorepType "Prelude.(->)"
- cast0to2 = cast2
+ dataCast2 = gcast2
------------------------------------------------------------------------------
-tuple0Constr = mkDataCon tuple0DataType "()" Prefix
+tuple0Constr = mkConstr tuple0DataType "()" [] Prefix
tuple0DataType = mkDataType "Prelude.()" [tuple0Constr]
instance Data () where
toConstr _ = tuple0Constr
- fromConstr c | conIndex c == 1 = ()
+ fromConstr c | constrIndex c == 1 = ()
fromConstr _ = error "fromConstr"
dataTypeOf _ = tuple0DataType
------------------------------------------------------------------------------
-tuple2Constr = mkDataCon tuple2DataType "(,)" Infix
+tuple2Constr = mkConstr tuple2DataType "(,)" [] Infix
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
- fromConstr c | conIndex c == 1 = (undefined,undefined)
+ fromConstr c | constrIndex c == 1 = (undefined,undefined)
fromConstr _ = error "fromConstr"
dataTypeOf _ = tuple2DataType
- cast0to2 = cast2
+ dataCast2 = gcast2
------------------------------------------------------------------------------
-tuple3Constr = mkDataCon tuple3DataType "(,,)" Infix
+tuple3Constr = mkConstr tuple3DataType "(,,)" [] Infix
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
- fromConstr c | conIndex c == 1 = (undefined,undefined,undefined)
+ fromConstr c | constrIndex c == 1 = (undefined,undefined,undefined)
fromConstr _ = error "fromConstr"
dataTypeOf _ = tuple3DataType
------------------------------------------------------------------------------
-tuple4Constr = mkDataCon tuple4DataType "(,,,)" Infix
+tuple4Constr = mkConstr tuple4DataType "(,,,)" [] Infix
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
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> (undefined,undefined,undefined,undefined)
_ -> error "fromConstr"
dataTypeOf _ = tuple4DataType
------------------------------------------------------------------------------
-tuple5Constr = mkDataCon tuple5DataType "(,,,,)" Infix
+tuple5Constr = mkConstr tuple5DataType "(,,,,)" [] Infix
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
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> (undefined,undefined,undefined,undefined,undefined)
_ -> error "fromConstr"
dataTypeOf _ = tuple5DataType
------------------------------------------------------------------------------
-tuple6Constr = mkDataCon tuple6DataType "(,,,,,)" Infix
+tuple6Constr = mkConstr tuple6DataType "(,,,,,)" [] Infix
tuple6DataType = mkDataType "Prelude.(,,,,,)" [tuple6Constr]
instance (Data a, Data b, Data c, Data d, Data e, Data f)
gfoldl f z (a,b,c,d,e,f') = z (,,,,,) `f` a `f` b `f` c `f` d `f` e `f` f'
toConstr _ = tuple6Constr
fromConstr c =
- case conIndex c of
+ case constrIndex c of
1 -> (undefined,undefined,undefined,undefined,undefined,undefined)
_ -> error "fromConstr"
dataTypeOf _ = tuple6DataType
------------------------------------------------------------------------------
-tuple7Constr = mkDataCon tuple7DataType "(,,,,,,)" Infix
+tuple7Constr = mkConstr tuple7DataType "(,,,,,,)" [] Infix
tuple7DataType = mkDataType "Prelude.(,,,,,,)" [tuple7Constr]
instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g)
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
- fromConstr c = case conIndex c of
+ fromConstr c = case constrIndex c of
1 -> (undefined,undefined,undefined,undefined,undefined,undefined,undefined)
_ -> error "fromConstr"
dataTypeOf _ = tuple7DataType
listify,
something,
synthesize,
+ gsize,
+ glength,
+ gdepth,
+ gcount,
+ gnodecount,
+ gtypecount,
+ gfindtype
) where
--
synthesize :: s -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
+
+
+-- | Compute size of an arbitrary data structure
+gsize :: Data a => a -> Int
+gsize t = 1 + sum (gmapQ gsize t)
+
+
+-- | Count the number of immediate subterms of the given term
+glength :: GenericQ Int
+glength = length . gmapQ (const ())
+
+
+-- | Determine depth of the given term
+gdepth :: GenericQ Int
+gdepth = (+) 1 . foldr max 0 . gmapQ gdepth
+
+
+-- | Determine the number of all suitable nodes in a given term
+gcount :: GenericQ Bool -> GenericQ Int
+gcount p = everything (+) (\x -> if p x then 1 else 0)
+
+
+-- | Determine the number of all nodes in a given term
+gnodecount :: GenericQ Int
+gnodecount = gcount (const True)
+
+
+-- | Determine the number of nodes of a given type in a given term
+gtypecount :: Typeable a => a -> GenericQ Int
+gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))
+
+
+-- | Find (unambiguously) an immediate subterm of a given type
+gfindtype :: (Data x, Data y) => x -> Maybe y
+gfindtype = singleton
+ . foldl unJust []
+ . gmapQ (Nothing `mkQ` Just)
+ where
+ unJust l (Just x) = x:l
+ unJust l Nothing = l
+ singleton [s] = Just s
+ singleton _ = Nothing
--
gshow = ( \t ->
"("
- ++ conString (toConstr t)
+ ++ showConstr (toConstr t)
++ concat (gmapQ ((++) " " . gshow) t)
++ ")"
) `extQ` (show :: String -> String)
-- failing in the monad if it isn't a constructor of this data type
str2con :: String -> ReadP Constr
str2con = maybe mzero return
- . stringCon myDataType
+ . readConstr myDataType
-- Get a Constr's string at the front of an input string
parseConstr :: ReadP String
-----------------------------------------------------------------------------
-- |
-- Module : Data.Generics.Twins
--- Copyright : (c) The University of Glasgow, CWI 2001--2003
+-- Copyright : (c) The University of Glasgow, CWI 2001--2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- * Type-safe cast
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
- cast0, -- a flexible variation on cast
+ gcast, -- a flexible variation on cast
-- * Type representations
TypeRep, -- abstract, instance of: Eq, Show, Typeable
-- * The Typeable1 class
Typeable1( typeOf1 ), -- :: t a -> TyCon
Typeable2( typeOf2 ), -- :: t a b -> TyCon
- cast1, -- :: ... => c (t a) -> Maybe (c (t' a))
- cast2 -- :: ... => c (t a b) -> Maybe (c (t' a b))
+ gcast1, -- :: ... => c (t a) -> Maybe (c (t' a))
+ gcast2 -- :: ... => c (t a b) -> Maybe (c (t' a b))
) where
-- | A flexible variation parameterised in a type constructor
-cast0 :: (Typeable a, Typeable b) => c a -> Maybe (c b)
-cast0 x = r
+gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
+gcast x = r
where
r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
then Just $ unsafeCoerce x
-- | Variant for unary type constructors
class Typeable1 t where
- typeOf1 :: t a -> TyCon
+ typeOf1 :: t a -> TypeRep
-- | Variant for binary type constructors
class Typeable2 t where
- typeOf2 :: t a b -> TyCon
+ typeOf2 :: t a b -> TypeRep
#ifndef __NHC__
-- | Instance for lists
instance Typeable1 [] where
- typeOf1 _ = typerepTyCon (typeOf (undefined::[()]))
+ typeOf1 _ = mkAppTy (typerepTyCon (typeOf (undefined::[()]))) []
-- | Instance for maybes
instance Typeable1 Maybe where
- typeOf1 _ = typerepTyCon (typeOf (undefined::Maybe ()))
+ typeOf1 _ = mkAppTy (typerepTyCon (typeOf (undefined::Maybe ()))) []
-- | Instance for ratios
instance Typeable1 Ratio where
- typeOf1 _ = typerepTyCon (typeOf (undefined::Ratio ()))
+ typeOf1 _ = mkAppTy (typerepTyCon (typeOf (undefined::Ratio ()))) []
-- | Instance for products
instance Typeable2 (,) where
- typeOf2 _ = typerepTyCon (typeOf (undefined::((),())))
+ typeOf2 _ = mkAppTy (typerepTyCon (typeOf (undefined::((),())))) []
-- | Instance for sums
instance Typeable2 Either where
- typeOf2 _ = typerepTyCon (typeOf (undefined::Either () ()))
+ typeOf2 _ = mkAppTy (typerepTyCon (typeOf (undefined::Either () ()))) []
-- | Instance for functions
instance Typeable2 (->) where
- typeOf2 _ = typerepTyCon (typeOf (undefined::() -> ()))
+ typeOf2 _ = mkAppTy (typerepTyCon (typeOf (undefined::() -> ()))) []
#endif
-- | Cast for * -> *
-cast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
-cast1 x = r
+gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
+gcast1 x = r
where
r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
then Just $ unsafeCoerce x
-- | Cast for * -> * -> *
-cast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b))
-cast2 x = r
+gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b))
+gcast2 x = r
where
r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
then Just $ unsafeCoerce x
projects / ghc-base.git / commitdiff