diff options
30 files changed, 325 insertions, 28 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index f14ab4d98c..33c65980ec 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -14,6 +14,8 @@ types that \end{itemize} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module BasicTypes( Version, bumpVersion, initialVersion, @@ -67,6 +69,8 @@ module BasicTypes( import FastString import Outputable + +import Data.Data hiding (Fixity) \end{code} %************************************************************************ @@ -87,7 +91,7 @@ type Arity = Int \begin{code} data FunctionOrData = IsFunction | IsData - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) instance Outputable FunctionOrData where ppr IsFunction = text "(function)" @@ -122,7 +126,7 @@ initialVersion = 1 -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt = WarningTxt [FastString] | DeprecatedTxt [FastString] - deriving Eq + deriving (Eq, Data, Typeable) instance Outputable WarningTxt where ppr (WarningTxt ws) = doubleQuotes (vcat (map ftext ws)) @@ -141,8 +145,9 @@ early in the hierarchy), but also in HsSyn. \begin{code} newtype IPName name = IPName name -- ?x - deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map - -- (used in HscTypes.OrigIParamCache) + deriving( Eq, Ord, Data, Typeable ) + -- Ord is used in the IP name cache finite map + -- (used in HscTypes.OrigIParamCache) ipNameName :: IPName name -> name ipNameName (IPName n) = n @@ -173,6 +178,7 @@ type RuleName = FastString \begin{code} ------------------------ data Fixity = Fixity Int FixityDirection + deriving (Data, Typeable) instance Outputable Fixity where ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] @@ -182,7 +188,7 @@ instance Eq Fixity where -- Used to determine if two fixities conflict ------------------------ data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) + deriving (Eq, Data, Typeable) instance Outputable FixityDirection where ppr InfixL = ptext (sLit "infixl") @@ -263,7 +269,7 @@ instance Outputable TopLevelFlag where data Boxity = Boxed | Unboxed - deriving( Eq ) + deriving( Eq, Data, Typeable ) isBoxed :: Boxity -> Bool isBoxed Boxed = True @@ -280,7 +286,7 @@ isBoxed Unboxed = False \begin{code} data RecFlag = Recursive | NonRecursive - deriving( Eq ) + deriving( Eq, Data, Typeable ) isRec :: RecFlag -> Bool isRec Recursive = True @@ -587,11 +593,11 @@ data Activation = NeverActive | AlwaysActive | ActiveBefore CompilerPhase -- Active only *before* this phase | ActiveAfter CompilerPhase -- Active in this phase and later - deriving( Eq ) -- Eq used in comparing rules in HsDecls + deriving( Eq, Data, Typeable ) -- Eq used in comparing rules in HsDecls data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] | FunLike - deriving( Eq ) + deriving( Eq, Data, Typeable ) data InlinePragma -- Note [InlinePragma] = InlinePragma @@ -601,7 +607,7 @@ data InlinePragma -- Note [InlinePragma] -- explicit (non-type, non-dictionary) args , inl_act :: Activation -- Says during which phases inlining is allowed , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? - } deriving( Eq ) + } deriving( Eq, Data, Typeable ) \end{code} Note [InlinePragma] diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 8f09078055..e4da52793c 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -54,6 +54,7 @@ import Util import FastString import Module +import qualified Data.Data as Data import Data.Char import Data.Word import Data.List ( partition ) @@ -454,6 +455,15 @@ instance Outputable DataCon where instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) + +instance Data.Typeable DataCon where + typeOf _ = Data.mkTyConApp (Data.mkTyCon "DataCon") [] + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" \end{code} diff --git a/compiler/basicTypes/Literal.lhs b/compiler/basicTypes/Literal.lhs index aa3cdd5d5d..a03e1c14e0 100644 --- a/compiler/basicTypes/Literal.lhs +++ b/compiler/basicTypes/Literal.lhs @@ -11,6 +11,7 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module Literal ( @@ -55,6 +56,7 @@ import Data.Int import Data.Ratio import Data.Word import Data.Char +import Data.Data \end{code} @@ -106,6 +108,7 @@ data Literal -- the label expects. Only applicable with -- @stdcall@ labels. @Just x@ => @\<x\>@ will -- be appended to label name when emitting assembly. + deriving (Data, Typeable) \end{code} Binary instance diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index f751380947..ef93a4739e 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -70,6 +70,8 @@ module Module emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet ) where +#include "Typeable.h" + import Config import Outputable import qualified Pretty @@ -80,6 +82,7 @@ import FastString import Binary import Util +import Data.Data import System.FilePath \end{code} @@ -171,6 +174,14 @@ instance Binary ModuleName where put_ bh (ModuleName fs) = put_ bh fs get bh = do fs <- get bh; return (ModuleName fs) +INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName") + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering -- ^ Compares module names lexically, rather than by their 'Unique's stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 @@ -224,6 +235,14 @@ instance Binary Module where put_ bh (Module p n) = put_ bh p >> put_ bh n get bh = do p <- get bh; n <- get bh; return (Module p n) +INSTANCE_TYPEABLE0(Module,moduleTc,"Module") + +instance Data Module where + -- don't traverse? + toConstr _ = abstractConstr "Module" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Module" + -- | This gives a stable ordering, as opposed to the Ord instance which -- gives an ordering based on the 'Unique's of the components, which may -- not be stable from run to run of the compiler. @@ -271,6 +290,14 @@ instance Uniquable PackageId where instance Ord PackageId where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 +INSTANCE_TYPEABLE0(PackageId,packageIdTc,"PackageId") + +instance Data PackageId where + -- don't traverse? + toConstr _ = abstractConstr "PackageId" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PackageId" + stablePackageIdCmp :: PackageId -> PackageId -> Ordering -- ^ Compares package ids lexically, rather than by their 'Unique's stablePackageIdCmp p1 p2 = packageIdFS p1 `compare` packageIdFS p2 diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index c3a1bd1fcd..f0cb443de1 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -69,12 +69,15 @@ module Name ( module OccName ) where +#include "Typeable.h" + import {-# SOURCE #-} TypeRep( TyThing ) import OccName import Module import SrcLoc import Unique +import Util import Maybes import Binary import StaticFlags @@ -83,6 +86,7 @@ import FastString import Outputable import Data.Array +import Data.Data import Data.Word ( Word32 ) \end{code} @@ -358,6 +362,14 @@ instance Uniquable Name where instance NamedThing Name where getName n = n + +INSTANCE_TYPEABLE0(Name,nameTc,"Name") + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" \end{code} %************************************************************************ diff --git a/compiler/basicTypes/NameSet.lhs b/compiler/basicTypes/NameSet.lhs index 46bcee72ab..c46127cbca 100644 --- a/compiler/basicTypes/NameSet.lhs +++ b/compiler/basicTypes/NameSet.lhs @@ -30,9 +30,13 @@ module NameSet ( ) where #include "HsVersions.h" +#include "Typeable.h" import Name import UniqSet +import Util + +import Data.Data \end{code} %************************************************************************ @@ -44,6 +48,14 @@ import UniqSet \begin{code} type NameSet = UniqSet Name +INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet") + +instance Data NameSet where + gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly + toConstr _ = abstractConstr "NameSet" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "NameSet" + emptyNameSet :: NameSet unitNameSet :: Name -> NameSet addListToNameSet :: NameSet -> [Name] -> NameSet diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 172c7097b3..9ff53f1340 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -92,6 +92,8 @@ module OccName ( startsVarSym, startsVarId, startsConSym, startsConId ) where +#include "Typeable.h" + import Util import Unique import BasicTypes @@ -102,6 +104,7 @@ import Outputable import Binary import StaticFlags( opt_SuppressUniques ) import Data.Char +import Data.Data \end{code} \begin{code} @@ -227,6 +230,14 @@ instance Ord OccName where -- Compares lexicographically, *not* by Unique of the string compare (OccName sp1 s1) (OccName sp2 s2) = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName") + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" \end{code} diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index a33c2430bb..69b791f6a9 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -4,6 +4,7 @@ % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} -- | -- #name_types# @@ -67,6 +68,8 @@ import SrcLoc import FastString import Outputable import Util + +import Data.Data \end{code} %************************************************************************ @@ -107,6 +110,7 @@ data RdrName -- (2) By Template Haskell, when TH has generated a unique name -- -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving (Data, Typeable) \end{code} diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index 1a01980959..8bed6c1977 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -69,11 +69,14 @@ module SrcLoc ( spans, isSubspanOf ) where +#include "Typeable.h" + import Util import Outputable import FastString import Data.Bits +import Data.Data \end{code} %************************************************************************ @@ -181,6 +184,14 @@ instance Outputable SrcLoc where char '\"', pprFastFilePath src_path, text " #-}"] ppr (UnhelpfulLoc s) = ftext s + +INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan") + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" \end{code} %************************************************************************ @@ -443,6 +454,7 @@ pprDefnLoc loc \begin{code} -- | We attach SrcSpans to lots of things, so let's have a datatype for it. data Located e = L SrcSpan e + deriving (Typeable, Data) unLoc :: Located e -> e unLoc (L _ e) = e diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index c52844b81e..5fd35ce7b7 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -75,6 +75,7 @@ module Var ( ) where #include "HsVersions.h" +#include "Typeable.h" import {-# SOURCE #-} TypeRep( Type, Kind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) @@ -83,9 +84,12 @@ import {-# SOURCE #-} TypeRep( isCoercionKind ) import Name hiding (varName) import Unique +import Util import FastTypes import FastString import Outputable + +import Data.Data \end{code} @@ -188,6 +192,14 @@ instance Ord Var where a >= b = realUnique a >=# realUnique b a > b = realUnique a ># realUnique b a `compare` b = varUnique a `compare` varUnique b + +INSTANCE_TYPEABLE0(Var,varTc,"Var") + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" \end{code} diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index b6b6659076..3c905af3e0 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -4,6 +4,7 @@ % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection module CoreSyn ( @@ -83,6 +84,7 @@ import FastString import Outputable import Util +import Data.Data import Data.Word infixl 4 `mkApps`, `mkTyApps`, `mkVarApps` @@ -218,6 +220,7 @@ data Expr b -- added to expressions in the syntax tree | Type Type -- ^ A type: this should only show up at the top -- level of an Arg + deriving (Data, Typeable) -- | Type synonym for expressions that occur in function argument positions. -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not @@ -233,11 +236,12 @@ data AltCon = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ - deriving (Eq, Ord) + deriving (Eq, Ord, Data, Typeable) -- | Binding, used for top level bindings in a module and local bindings in a @let@. data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] + deriving (Data, Typeable) \end{code} -------------------------- CoreSyn INVARIANTS --------------------------- @@ -277,6 +281,7 @@ See #type_let# data Note = SCC CostCentre -- ^ A cost centre annotation for profiling | CoreNote String -- ^ A generic core annotation, propagated but not used by GHC + deriving (Data, Typeable) \end{code} diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index f3648832f3..c4d38fd7a3 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -13,6 +13,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module HsBinds where @@ -34,6 +35,8 @@ import Util import Var import Bag import FastString + +import Data.Data hiding ( Fixity ) \end{code} %************************************************************************ @@ -58,6 +61,7 @@ data HsLocalBindsLR idL idR -- Bindings in a 'let' expression = HsValBinds (HsValBindsLR idL idR) | HsIPBinds (HsIPBinds idR) | EmptyLocalBinds + deriving (Data, Typeable) type HsValBinds id = HsValBindsLR id id @@ -71,6 +75,7 @@ data HsValBindsLR idL idR -- Value bindings (not implicit parameters) -- in the list may depend on earlier -- ones. [LSig Name] + deriving (Data, Typeable) type LHsBinds id = Bag (LHsBind id) type DictBinds id = LHsBinds id -- Used for dictionary or method bindings @@ -148,6 +153,7 @@ data HsBindLR idL idR -- mixed up together; you can tell the dict bindings because -- they are all VarBinds } + deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- -- Creates bindings for (polymorphic, overloaded) poly_f @@ -317,6 +323,7 @@ data HsIPBinds id [LIPBind id] (DictBinds id) -- Only in typechecker output; binds -- uses of the implicit parameters + deriving (Data, Typeable) isEmptyIPBinds :: HsIPBinds id -> Bool isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds @@ -328,6 +335,7 @@ data IPBind id = IPBind (IPName id) (LHsExpr id) + deriving (Data, Typeable) instance (OutputableBndr id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) @@ -370,6 +378,7 @@ data HsWrapper -- is always exactly WpHole | WpLet (LHsBinds Id) -- let binds in [] -- (would be nicer to be core bindings) + deriving (Data, Typeable) instance Outputable HsWrapper where ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn @@ -466,21 +475,25 @@ data Sig name -- Signatures and pragmas -- {-# SPECIALISE instance Eq [Int] #-} | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the -- current instance decl + deriving (Data, Typeable) type LFixitySig name = Located (FixitySig name) data FixitySig name = FixitySig (Located name) Fixity + deriving (Data, Typeable) -- TsSpecPrags conveys pragmas from the type checker to the desugarer data TcSpecPrags = IsDefaultMethod -- Super-specialised: a default method should -- be macro-expanded at every call site | SpecPrags [Located TcSpecPrag] + deriving (Data, Typeable) data TcSpecPrag = SpecPrag HsWrapper -- An wrapper, that specialises the polymorphic function InlinePragma -- Inlining spec for the specialised function + deriving (Data, Typeable) noSpecPrags :: TcSpecPrags noSpecPrags = SpecPrags [] diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 08d12b7f37..0038ebed0a 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -12,6 +12,7 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} -- | Abstract syntax of global declarations. -- @@ -76,6 +77,7 @@ import SrcLoc import FastString import Control.Monad ( liftM ) +import Data.Data import Data.Maybe ( isJust ) \end{code} @@ -103,6 +105,7 @@ data HsDecl id | SpliceD (SpliceDecl id) | DocD (DocDecl) | QuasiQuoteD (HsQuasiQuote id) + deriving (Data, Typeable) -- NB: all top-level fixity decls are contained EITHER @@ -138,7 +141,7 @@ data HsGroup id hs_ruleds :: [LRuleDecl id], hs_docs :: [LDocDecl] - } + } deriving (Data, Typeable) emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } @@ -230,6 +233,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where ppr_ds ds = blankLine $$ vcat (map ppr ds) data SpliceDecl id = SpliceDecl (Located (HsExpr id)) -- Top level splice + deriving (Data, Typeable) instance OutputableBndr name => Outputable (SpliceDecl name) where ppr (SpliceDecl e) = ptext (sLit "$") <> parens (pprExpr (unLoc e)) @@ -480,15 +484,17 @@ data TyClDecl name -- latter for defaults tcdDocs :: [LDocDecl] -- ^ Haddock docs } + deriving (Data, Typeable) data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ - deriving( Eq ) -- Needed because Demand derives Eq + deriving( Eq, Data, Typeable ) -- Needed because Demand derives Eq data FamilyFlavour = TypeFamily -- ^ @type family ...@ | DataFamily -- ^ @data family ...@ + deriving (Data, Typeable) \end{code} Simple classifiers @@ -726,7 +732,7 @@ data ConDecl name -- GADT-style record decl C { blah } :: T a b -- Remove this when we no longer parse this stuff, and hence do not -- need to report decprecated use - } + } deriving (Data, Typeable) type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name] @@ -739,6 +745,7 @@ data ResType name = ResTyH98 -- Constructor was declared using Haskell 98 syntax | ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax, -- and here is its result type + deriving (Data, Typeable) instance OutputableBndr name => Outputable (ResType name) where -- Debugging only @@ -814,6 +821,7 @@ data InstDecl name [LSig name] -- User-supplied pragmatic info [LTyClDecl name]-- Associated types (ie, 'TyData' and -- 'TySynonym' only) + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (InstDecl name) where @@ -839,6 +847,7 @@ instDeclATs (InstDecl _ _ _ ats) = ats type LDerivDecl name = Located (DerivDecl name) data DerivDecl name = DerivDecl (LHsType name) + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (DerivDecl name) where ppr (DerivDecl ty) @@ -860,6 +869,7 @@ type LDefaultDecl name = Located (DefaultDecl name) data DefaultDecl name = DefaultDecl [LHsType name] + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (DefaultDecl name) where @@ -887,6 +897,7 @@ type LForeignDecl name = Located (ForeignDecl name) data ForeignDecl name = ForeignImport (Located name) (LHsType name) ForeignImport -- defines name | ForeignExport (Located name) (LHsType name) ForeignExport -- uses name + deriving (Data, Typeable) -- Specification Of an imported external entity in dependence on the calling -- convention @@ -909,6 +920,7 @@ data ForeignImport = -- import of a C entity Safety -- safe or unsafe FastString -- name of C header CImportSpec -- details of the C entity + deriving (Data, Typeable) -- details of an external C entity -- @@ -916,11 +928,13 @@ data CImportSpec = CLabel CLabelString -- import address of a C label | CFunction CCallTarget -- static or dynamic function | CWrapper -- wrapper to expose closures -- (former f.e.d.) + deriving (Data, Typeable) -- specification of an externally exported entity in dependence on the calling -- convention -- data ForeignExport = CExport CExportSpec -- contains the calling convention + deriving (Data, Typeable) -- pretty printing of foreign declarations -- @@ -972,10 +986,12 @@ data RuleDecl name NameSet -- Free-vars from the LHS (Located (HsExpr name)) -- RHS NameSet -- Free-vars from the RHS + deriving (Data, Typeable) data RuleBndr name = RuleBndr (Located name) | RuleBndrSig (Located name) (LHsType name) + deriving (Data, Typeable) collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] @@ -1009,6 +1025,7 @@ data DocDecl | DocCommentPrev HsDocString | DocCommentNamed String HsDocString | DocGroup Int HsDocString + deriving (Data, Typeable) -- Okay, I need to reconstruct the document comments, but for now: instance Outputable DocDecl where @@ -1034,6 +1051,7 @@ We use exported entities for things to deprecate. type LWarnDecl name = Located (WarnDecl name) data WarnDecl name = Warning name WarningTxt + deriving (Data, Typeable) instance OutputableBndr name => Outputable (WarnDecl name) where ppr (Warning thing txt) @@ -1050,6 +1068,7 @@ instance OutputableBndr name => Outputable (WarnDecl name) where type LAnnDecl name = Located (AnnDecl name) data AnnDecl name = HsAnnotation (AnnProvenance name) (Located (HsExpr name)) + deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (AnnDecl name) where ppr (HsAnnotation provenance expr) @@ -1059,6 +1078,7 @@ instance (OutputableBndr name) => Outputable (AnnDecl name) where data AnnProvenance name = ValueAnnProvenance name | TypeAnnProvenance name | ModuleAnnProvenance + deriving (Data, Typeable) annProvenanceName_maybe :: AnnProvenance name -> Maybe name annProvenanceName_maybe (ValueAnnProvenance name) = Just name diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs index d8e5b677fb..1f3adafec1 100644 --- a/compiler/hsSyn/HsDoc.hs +++ b/compiler/hsSyn/HsDoc.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} + module HsDoc ( HsDocString(..), LHsDocString, @@ -10,8 +12,10 @@ import Outputable import SrcLoc import FastString +import Data.Data + newtype HsDocString = HsDocString FastString - deriving (Eq, Show) + deriving (Eq, Show, Data, Typeable) type LHsDocString = Located HsDocString diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index bde737a253..7930caa00d 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -3,6 +3,7 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} -- | Abstract Haskell syntax for expressions. module HsExpr where @@ -24,6 +25,9 @@ import DataCon import SrcLoc import Outputable import FastString + +-- libraries: +import Data.Data hiding (Fixity) \end{code} @@ -275,6 +279,7 @@ data HsExpr id | HsWrap HsWrapper -- TRANSLATION (HsExpr id) + deriving (Data, Typeable) -- HsTupArg is used for tuple sections -- (,a,) is represented by ExplicitTuple [Mising ty1, Present a, Missing ty3] @@ -282,6 +287,7 @@ data HsExpr id data HsTupArg id = Present (LHsExpr id) -- The argument | Missing PostTcType -- The argument is missing, but this is its type + deriving (Data, Typeable) tupArgPresent :: HsTupArg id -> Bool tupArgPresent (Present {}) = True @@ -587,6 +593,7 @@ type HsCmd id = HsExpr id type LHsCmd id = LHsExpr id data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving (Data, Typeable) \end{code} The legal constructors for commands are: @@ -640,6 +647,7 @@ data HsCmdTop id PostTcType -- return type of the command (SyntaxTable id) -- after type checking: -- names used in the command's desugaring + deriving (Data, Typeable) \end{code} %************************************************************************ @@ -681,6 +689,7 @@ data MatchGroup id PostTcType -- The type is the type of the entire group -- t1 -> ... -> tn -> tr -- where there are n patterns + deriving (Data, Typeable) type LMatch id = Located (Match id) @@ -690,6 +699,7 @@ data Match id (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking (GRHSs id) + deriving (Data, Typeable) isEmptyMatchGroup :: MatchGroup id -> Bool isEmptyMatchGroup (MatchGroup ms _) = null ms @@ -712,13 +722,14 @@ data GRHSs id = GRHSs { grhssGRHSs :: [LGRHS id], -- ^ Guarded RHSs grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause - } + } deriving (Data, Typeable) type LGRHS id = Located (GRHS id) -- | Guarded Right Hand Side. data GRHS id = GRHS [LStmt id] -- Guards (LHsExpr id) -- Right hand side + deriving (Data, Typeable) \end{code} We know the list must have at least one @Match@ in it. @@ -887,6 +898,7 @@ data StmtLR idL idR , recS_dicts :: DictBinds idR -- Method bindings of Ids bound by the -- RecStmt, and used afterwards } + deriving (Data, Typeable) \end{code} Note [GroupStmt binder map] @@ -1047,6 +1059,7 @@ pprComp quals body -- Prints: body | qual1, ..., qualn data HsSplice id = HsSplice -- $z or $(f 4) id -- The id is just a unique name to (LHsExpr id) -- identify this splice point + deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsSplice id) where ppr = pprSplice @@ -1062,6 +1075,7 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | DecBrG (HsGroup id) -- [d| decls |]; result of renamer | TypBr (LHsType id) -- [t| type |] | VarBr id -- 'x, ''T + deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsBracket id) where ppr = pprHsBracket @@ -1100,6 +1114,7 @@ data ArithSeqInfo id | FromThenTo (LHsExpr id) (LHsExpr id) (LHsExpr id) + deriving (Data, Typeable) \end{code} \begin{code} @@ -1133,7 +1148,7 @@ data HsMatchContext id -- Context of a Match -- runtime error message to generate] | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] - deriving () + deriving (Data, Typeable) data HsStmtContext id = ListComp @@ -1146,6 +1161,7 @@ data HsStmtContext id | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + deriving (Data, Typeable) \end{code} \begin{code} diff --git a/compiler/hsSyn/HsExpr.lhs-boot b/compiler/hsSyn/HsExpr.lhs-boot index e0b4d047e7..272bdbd6a8 100644 --- a/compiler/hsSyn/HsExpr.lhs-boot +++ b/compiler/hsSyn/HsExpr.lhs-boot @@ -4,12 +4,19 @@ module HsExpr where import SrcLoc ( Located ) import Outputable ( SDoc, OutputableBndr ) import {-# SOURCE #-} HsPat ( LPat ) + +import Data.Data data HsExpr i data HsSplice i data MatchGroup a data GRHSs a +instance Data i => Data (HsSplice i) +instance Data i => Data (HsExpr i) +instance Data i => Data (MatchGroup i) +instance Data i => Data (GRHSs i) + type LHsExpr a = Located (HsExpr a) type SyntaxExpr a = HsExpr a diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 5870176278..dd24aedb2b 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -12,6 +12,7 @@ HsImpExp: Abstract syntax: imports, exports, interfaces -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module HsImpExp where @@ -21,6 +22,8 @@ import HsDoc ( HsDocString ) import Outputable import FastString import SrcLoc ( Located(..) ) + +import Data.Data \end{code} %************************************************************************ @@ -42,7 +45,7 @@ data ImportDecl name ideclQualified :: Bool, -- ^ True => qualified ideclAs :: Maybe ModuleName, -- ^ as Module ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) - } + } deriving (Data, Typeable) \end{code} \begin{code} @@ -91,6 +94,7 @@ data IE name | IEGroup Int HsDocString -- ^ Doc section heading | IEDoc HsDocString -- ^ Some documentation | IEDocNamed String -- ^ Reference to named doc + deriving (Data, Typeable) \end{code} \begin{code} diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index 9a0e8750e6..0874dda858 100644 --- a/compiler/hsSyn/HsLit.lhs +++ b/compiler/hsSyn/HsLit.lhs @@ -5,6 +5,8 @@ \section[HsLit]{Abstract syntax: source-language literals} \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module HsLit where #include "HsVersions.h" @@ -14,6 +16,8 @@ import HsTypes (PostTcType) import Type ( Type ) import Outputable import FastString + +import Data.Data \end{code} @@ -40,6 +44,7 @@ data HsLit -- (overloaded literals are done with HsOverLit) | HsFloatPrim Rational -- Unboxed Float | HsDoublePrim Rational -- Unboxed Double + deriving (Data, Typeable) instance Eq HsLit where (HsChar x1) == (HsChar x2) = x1==x2 @@ -62,11 +67,13 @@ data HsOverLit id -- An overloaded literal -- False <=> standard syntax ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] ol_type :: PostTcType } + deriving (Data, Typeable) data OverLitVal = HsIntegral !Integer -- Integer-looking literals; | HsFractional !Rational -- Frac-looking literals | HsIsString !FastString -- String-looking literals + deriving (Data, Typeable) overLitType :: HsOverLit a -> Type overLitType = ol_type diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 8ab583a28c..c025a8dc35 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/compiler/hsSyn/HsPat.lhs @@ -11,6 +11,7 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module HsPat ( Pat(..), InPat, OutPat, LPat, @@ -46,6 +47,8 @@ import Outputable import Type import SrcLoc import FastString +-- libraries: +import Data.Data hiding (TyCon) \end{code} @@ -151,6 +154,7 @@ data Pat id Type -- Type of whole pattern, t1 -- During desugaring a (CoPat co pat) turns into a cast with 'co' on -- the scrutinee, followed by a match on 'pat' + deriving (Data, Typeable) \end{code} HsConDetails is use for patterns/expressions *and* for data type declarations @@ -160,6 +164,7 @@ data HsConDetails arg rec = PrefixCon [arg] -- C p1 p2 p3 | RecCon rec -- C { x = p1, y = p2 } | InfixCon arg arg -- p1 `C` p2 + deriving (Data, Typeable) type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id)) @@ -178,6 +183,7 @@ data HsRecFields id arg -- A bunch of record fields -- Used for both expressions and patterns = HsRecFields { rec_flds :: [HsRecField id arg], rec_dotdot :: Maybe Int } -- Note [DotDot fields] + deriving (Data, Typeable) -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~ @@ -197,7 +203,7 @@ data HsRecField id arg = HsRecField { hsRecFieldId :: Located id, hsRecFieldArg :: arg, -- Filled in by renamer hsRecPun :: Bool -- Note [Punning] - } + } deriving (Data, Typeable) -- Note [Punning] -- ~~~~~~~~~~~~~~ diff --git a/compiler/hsSyn/HsPat.lhs-boot b/compiler/hsSyn/HsPat.lhs-boot index d5b685c1f1..5a8726fab9 100644 --- a/compiler/hsSyn/HsPat.lhs-boot +++ b/compiler/hsSyn/HsPat.lhs-boot @@ -2,6 +2,10 @@ module HsPat where import SrcLoc( Located ) +import Data.Data + data Pat i type LPat i = Located (Pat i) + +instance Data i => Data (Pat i) \end{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index 1365e1dbae..39093f2550 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -9,6 +9,8 @@ which is declared in the various \tr{Hs*} modules. This module, therefore, is almost nothing but re-exporting. \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module HsSyn ( module HsBinds, module HsDecls, @@ -42,6 +44,9 @@ import Outputable import SrcLoc ( Located(..) ) import Module ( Module, ModuleName ) import FastString + +-- libraries: +import Data.Data hiding ( Fixity ) \end{code} \begin{code} @@ -70,8 +75,7 @@ data HsModule name -- ^ reason\/explanation for warning/deprecation of this module hsmodHaddockModHeader :: Maybe LHsDocString -- ^ Haddock module info and description, unparsed - } - + } deriving (Data, Typeable) data HsExtCore name -- Read from Foo.hcr = HsExtCore diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 2e2eaabccf..9b3930531e 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -6,6 +6,8 @@ HsTypes: Abstract syntax: user-defined types \begin{code} +{-# LANGUAGE DeriveDataTypeable #-} + module HsTypes ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, @@ -42,6 +44,8 @@ import SrcLoc import StaticFlags import Outputable import FastString + +import Data.Data \end{code} @@ -76,6 +80,7 @@ data HsQuasiQuote id = HsQuasiQuote id -- The quasi-quoter SrcSpan -- The span of the enclosed string FastString -- The enclosed string + deriving (Data, Typeable) instance OutputableBndr id => Outputable (HsQuasiQuote id) where ppr = ppr_qq @@ -101,6 +106,7 @@ data HsBang = HsNoBang -- Only used as a return value for getBangStrictness, -- never appears on a HsBangTy | HsStrict -- ! | HsUnbox -- {-# UNPACK #-} ! (GHC extension, meaning "unbox") + deriving (Data, Typeable) instance Outputable HsBang where ppr (HsNoBang) = empty @@ -135,6 +141,7 @@ type LHsPred name = Located (HsPred name) data HsPred name = HsClassP name [LHsType name] -- class constraint | HsEqualP (LHsType name) (LHsType name)-- equality constraint | HsIParam (IPName name) (LHsType name) + deriving (Data, Typeable) type LHsType name = Located (HsType name) @@ -194,14 +201,15 @@ data HsType name | HsBangTy HsBang (LHsType name) -- Bang-style type annotations | HsRecTy [ConDeclField name] -- Only in data type declarations + deriving (Data, Typeable) -data HsExplicitFlag = Explicit | Implicit +data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable) data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_name :: Located name, cd_fld_type :: LBangType name, cd_fld_doc :: Maybe LHsDocString } - + deriving (Data, Typeable) ----------------------- -- Combine adjacent for-alls. @@ -257,6 +265,7 @@ data HsTyVarBndr name -- *** NOTA BENE *** A "monotype" in a pragma can have -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. + deriving (Data, Typeable) hsTyVarName :: HsTyVarBndr name -> name hsTyVarName (UserTyVar n _) = n diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs index 4423d0317c..63c902963b 100644 --- a/compiler/prelude/ForeignCall.lhs +++ b/compiler/prelude/ForeignCall.lhs @@ -10,6 +10,7 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module ForeignCall ( ForeignCall(..), @@ -27,6 +28,7 @@ import Outputable import Module import Data.Char +import Data.Data \end{code} @@ -63,7 +65,7 @@ data Safety | PlayRisky -- None of the above can happen; the call will return -- without interacting with the runtime system at all - deriving ( Eq, Show ) + deriving ( Eq, Show, Data, Typeable ) -- Show used just for Show Lex.Token, I think {-! derive: Binary !-} @@ -89,6 +91,7 @@ data CExportSpec = CExportStatic -- foreign export ccall foo :: ty CLabelString -- C Name of exported function CCallConv + deriving (Data, Typeable) {-! derive: Binary !-} data CCallSpec @@ -121,7 +124,7 @@ data CCallTarget -- Used when importing a label as "foreign import ccall "dynamic" ..." | DynamicTarget - deriving( Eq ) + deriving( Eq, Data, Typeable ) {-! derive: Binary !-} isDynamicTarget :: CCallTarget -> Bool @@ -146,7 +149,7 @@ See: http://www.programmersheaven.com/2/Calling-conventions \begin{code} data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv - deriving (Eq) + deriving (Eq, Data, Typeable) {-! derive: Binary !-} instance Outputable CCallConv where diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 444b8be112..2648d1eff2 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -10,6 +10,7 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE DeriveDataTypeable #-} module CostCentre ( CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), @@ -44,6 +45,8 @@ import Outputable import FastTypes import FastString import Util ( thenCmp ) + +import Data.Data \end{code} A Cost Centre Stack is something that can be attached to a closure. @@ -123,6 +126,7 @@ data CostCentre | AllCafsCC { cc_mod :: Module -- Name of module defining this CC. } + deriving (Data, Typeable) type CcName = FastString @@ -141,8 +145,10 @@ data IsDupdCC -- but we are trying to avoid confusion between -- "subd" and "subsumed". So we call the former -- "dupd". + deriving (Data, Typeable) data IsCafCC = CafCC | NotCafCC + deriving (Data, Typeable) -- synonym for triple which describes the cost centre info in the generated -- code for a module. diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs index e7bda63176..5e8a4d4bdd 100644 --- a/compiler/types/Class.lhs +++ b/compiler/types/Class.lhs @@ -17,6 +17,8 @@ module Class ( classBigSig, classExtraBigSig, classTvsFds, classSCTheta ) where +#include "Typeable.h" + import {-# SOURCE #-} TyCon ( TyCon ) import {-# SOURCE #-} TypeRep ( PredType ) @@ -24,8 +26,11 @@ import Var import Name import BasicTypes import Unique +import Util import Outputable import FastString + +import qualified Data.Data as Data \end{code} %************************************************************************ @@ -178,5 +183,14 @@ pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds)) pprFunDep :: Outputable a => FunDep a -> SDoc pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] + +instance Data.Typeable Class where + typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") [] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" \end{code} diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index 963f93c2e3..340ccbaa96 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -95,6 +95,8 @@ import Maybes import Outputable import FastString import Constants +import Util +import qualified Data.Data as Data import Data.List( elemIndex ) \end{code} @@ -1251,4 +1253,13 @@ instance Outputable TyCon where instance NamedThing TyCon where getName = tyConName + +instance Data.Typeable TyCon where + typeOf _ = Data.mkTyConApp (Data.mkTyCon "TyCon") [] + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" \end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index 1660267b4e..819a71ce57 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -7,6 +7,7 @@ \begin{code} -- We expose the relevant stuff from this module via the Type module {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable #-} module TypeRep ( TyThing(..), @@ -61,6 +62,9 @@ import Class import PrelNames import Outputable import FastString + +-- libraries +import Data.Data hiding ( TyCon ) \end{code} ---------------------- @@ -155,6 +159,7 @@ data Type -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam') -- See Note [PredTy], and Note [Equality predicates] + deriving (Data, Typeable) -- | The key type representing kinds in the compiler. -- Invariant: a kind is always in one of these forms: @@ -196,6 +201,7 @@ data PredType = ClassP Class [Type] -- ^ Class predicate e.g. @Eq a@ | IParam (IPName Name) Type -- ^ Implicit parameter e.g. @?x :: Int@ | EqPred Type Type -- ^ Equality predicate e.g @ty1 ~ ty2@ + deriving (Data, Typeable) -- | A collection of 'PredType's type ThetaType = [PredType] diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs index ebc44ac147..b2be2c30db 100644 --- a/compiler/utils/Bag.lhs +++ b/compiler/utils/Bag.lhs @@ -18,9 +18,12 @@ module Bag ( mapBagM, mapAndUnzipBagM ) where +#include "Typeable.h" + import Outputable -import Util ( isSingleton ) +import Util +import Data.Data import Data.List ( partition ) infixr 3 `consBag` @@ -188,4 +191,12 @@ bagToList b = foldrBag (:) [] b \begin{code} instance (Outputable a) => Outputable (Bag a) where ppr bag = braces (pprWithCommas ppr (bagToList bag)) + +INSTANCE_TYPEABLE1(Bag,bagTc,"Bag") + +instance Data a => Data (Bag a) where + gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly + toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Bag" \end{code} diff --git a/compiler/utils/FastString.lhs b/compiler/utils/FastString.lhs index 055f921213..8fcd419a2a 100644 --- a/compiler/utils/FastString.lhs +++ b/compiler/utils/FastString.lhs @@ -93,12 +93,14 @@ import Encoding import FastTypes import FastFunctions import Panic +import Util import Foreign import Foreign.C import GHC.Exts import System.IO import System.IO.Unsafe ( unsafePerformIO ) +import Data.Data import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) import Data.Maybe ( isJust ) import Data.Char ( ord ) @@ -133,7 +135,7 @@ data FastString = FastString { n_chars :: {-# UNPACK #-} !Int, -- number of chars buf :: {-# UNPACK #-} !(ForeignPtr Word8), enc :: FSEncoding - } + } deriving Typeable data FSEncoding -- including strings that don't need any encoding @@ -159,6 +161,12 @@ instance Ord FastString where instance Show FastString where show fs = show (unpackFS fs) +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + cmpFS :: FastString -> FastString -> Ordering cmpFS (FastString u1 l1 _ buf1 _) (FastString u2 l2 _ buf2 _) = if u1 == u2 then EQ else diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index c5a826a482..fbbe767178 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -76,12 +76,16 @@ module Util ( escapeSpaces, parseSearchPath, Direction(..), reslash, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType ) where #include "HsVersions.h" import Panic +import Data.Data import Data.IORef ( IORef, newIORef, atomicModifyIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) @@ -902,3 +906,29 @@ reslash d = f Backwards -> '\\' \end{code} +%************************************************************************ +%* * +\subsection[Utils-Data]{Utils for defining Data instances} +%* * +%************************************************************************ + +These functions helps us to define Data instances for abstract types. + +\begin{code} +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix +\end{code} + +\begin{code} +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] +\end{code} + +\begin{code} +-- Old GHC versions come with a base library with this function misspelled. +#if __GLASGOW_HASKELL__ < 612 +mkNoRepType :: String -> DataType +mkNoRepType = mkNorepType +#endif +\end{code} + |