Commit f278f067 authored by waern's avatar waern

Add Data and Typeable instances to HsSyn

The instances (and deriving declarations) have been taken from the ghc-syb
package.
parent ef6e8211
......@@ -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]
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......
......@@ -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 []
......
......@@ -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)