Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
f278f067
Commit
f278f067
authored
Mar 30, 2010
by
waern
Browse files
Add Data and Typeable instances to HsSyn
The instances (and deriving declarations) have been taken from the ghc-syb package.
parent
ef6e8211
Changes
30
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/BasicTypes.lhs
View file @
f278f067
...
...
@@ -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]
...
...
compiler/basicTypes/DataCon.lhs
View file @
f278f067
...
...
@@ -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}
...
...
compiler/basicTypes/Literal.lhs
View file @
f278f067
...
...
@@ -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
...
...
compiler/basicTypes/Module.lhs
View file @
f278f067
...
...
@@ -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
...
...
compiler/basicTypes/Name.lhs
View file @
f278f067
...
...
@@ -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}
%************************************************************************
...
...
compiler/basicTypes/NameSet.lhs
View file @
f278f067
...
...
@@ -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
...
...
compiler/basicTypes/OccName.lhs
View file @
f278f067
...
...
@@ -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}
...
...
compiler/basicTypes/RdrName.lhs
View file @
f278f067
...
...
@@ -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}
...
...
compiler/basicTypes/SrcLoc.lhs
View file @
f278f067
...
...
@@ -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
...
...
compiler/basicTypes/Var.lhs
View file @
f278f067
...
...
@@ -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}
...
...
compiler/coreSyn/CoreSyn.lhs
View file @
f278f067
...
...
@@ -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}
...
...
compiler/hsSyn/HsBinds.lhs
View file @
f278f067
...
...
@@ -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 []
...
...
compiler/hsSyn/HsDecls.lhs
View file @
f278f067
...
...
@@ -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