%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
-%************************************************************************
-%* *
-\section[HsCore]{Core-syntax unfoldings in Haskell interface files}
-%* *
-%************************************************************************
-
-We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
-@TyVars@ as well. Currently trying the former... MEGA SIGH.
\begin{code}
module IfaceSyn (
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
- IfaceExpr(..), IfaceAlt, IfaceNote(..),
- IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceInst(..),
+ IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
+ IfaceBinding(..), IfaceConAlt(..),
+ IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceInst(..), IfaceFamInst(..),
-- Misc
- visibleIfConDecls,
+ ifaceDeclSubBndrs, visibleIfConDecls,
- -- Converting things to IfaceSyn
- tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule,
+ -- Free Names
+ freeNamesIfDecl, freeNamesIfRule,
- -- Equality
- IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
- eqIfDecl, eqIfInst, eqIfRule,
-
-- Pretty printing
- pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead
+ pprIfaceExpr, pprIfaceDeclHead
) where
#include "HsVersions.h"
-import CoreSyn
import IfaceType
-import FunDeps ( pprFundeps )
-import NewDemand ( StrictSig, pprIfaceStrictSig )
-import TcType ( deNoteType )
-import Type ( TyThing(..), splitForAllTys, funResultTy )
-import InstEnv ( Instance(..), OverlapFlag )
-import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe )
-import NewDemand ( isTopSig )
-import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..),
- arityInfo, cafInfo, newStrictnessInfo,
- workerInfo, unfoldingInfo, inlinePragInfo )
-import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon,
- isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon,
- isTupleTyCon, tupleTyConBoxity, tyConStupidTheta,
- tyConHasGenerics, tyConArgVrcs, synTyConRhs,
- tyConArity, tyConTyVars, algTyConRhs, tyConExtName )
-import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks,
- dataConTyCon, dataConIsInfix, isVanillaDataCon )
-import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon )
-import OccName ( OccName, OccEnv, emptyOccEnv,
- lookupOccEnv, extendOccEnv, parenSymOcc,
- OccSet, unionOccSets, unitOccSet )
-import Name ( Name, NamedThing(..), nameOccName, isExternalName )
-import CostCentre ( CostCentre, pprCostCentreCore )
-import Literal ( Literal )
-import ForeignCall ( ForeignCall )
-import TysPrim ( alphaTyVars )
-import BasicTypes ( Arity, Activation(..), StrictnessMark,
- RecFlag(..), boolToRecFlag, Boxity(..),
- tupleParens )
+import Demand
+import Annotations
+import Class
+import NameSet
+import Name
+import CostCentre
+import Literal
+import ForeignCall
+import Serialized
+import BasicTypes
import Outputable
import FastString
-import Maybes ( catMaybes )
-import Util ( lengthIs )
+import Module
infixl 3 &&&
-infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
\end{code}
\begin{code}
data IfaceDecl
- = IfaceId { ifName :: OccName,
- ifType :: IfaceType,
- ifIdInfo :: IfaceIdInfo }
-
- | IfaceData { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifCtxt :: IfaceContext, -- The "stupid theta"
- ifCons :: IfaceConDecls, -- Includes new/data info
- ifRec :: RecFlag, -- Recursive or not?
- ifVrcs :: ArgVrcs,
- ifGeneric :: Bool -- True <=> generic converter functions available
- } -- We need this for imported data decls, since the
- -- imported modules may have been compiled with
- -- different flags to the current compilation unit
-
- | IfaceSyn { ifName :: OccName, -- Type constructor
- ifTyVars :: [IfaceTvBndr], -- Type variables
- ifVrcs :: ArgVrcs,
- ifSynRhs :: IfaceType -- synonym expansion
+ = IfaceId { ifName :: OccName,
+ ifType :: IfaceType,
+ ifIdDetails :: IfaceIdDetails,
+ ifIdInfo :: IfaceIdInfo }
+
+ | IfaceData { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifCtxt :: IfaceContext, -- The "stupid theta"
+ ifCons :: IfaceConDecls, -- Includes new/data info
+ ifRec :: RecFlag, -- Recursive or not?
+ ifGadtSyntax :: Bool, -- True <=> declared using
+ -- GADT syntax
+ ifGeneric :: Bool, -- True <=> generic converter
+ -- functions available
+ -- We need this for imported
+ -- data decls, since the
+ -- imported modules may have
+ -- been compiled with
+ -- different flags to the
+ -- current compilation unit
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ -- Just <=> instance of family
+ -- Invariant:
+ -- ifCons /= IfOpenDataTyCon
+ -- for family instances
+ }
+
+ | IfaceSyn { ifName :: OccName, -- Type constructor
+ ifTyVars :: [IfaceTvBndr], -- Type variables
+ ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon)
+ ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn
+ -- Nothing for an open family
+ ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ -- Just <=> instance of family
+ -- Invariant: ifOpenSyn == False
+ -- for family instances
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class
ifTyVars :: [IfaceTvBndr], -- Type variables
- ifFDs :: [FunDep OccName], -- Functional dependencies
+ ifFDs :: [FunDep FastString], -- Functional dependencies
+ ifATs :: [IfaceDecl], -- Associated type families
ifSigs :: [IfaceClassOp], -- Method signatures
- ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
- ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
+ ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive?
}
- | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
+ | IfaceForeign { ifName :: OccName, -- Needs expanding when we move
+ -- beyond .NET
ifExtName :: Maybe FastString }
data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
data IfaceConDecls
= IfAbstractTyCon -- No info
+ | IfOpenDataTyCon -- Open data family
| IfDataTyCon [IfaceConDecl] -- data type decls
| IfNewTyCon IfaceConDecl -- newtype decls
visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
visibleIfConDecls IfAbstractTyCon = []
+visibleIfConDecls IfOpenDataTyCon = []
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c) = [c]
data IfaceConDecl
- = IfVanillaCon {
- ifConOcc :: OccName, -- Constructor name
+ = IfCon {
+ ifConOcc :: OccName, -- Constructor name
+ ifConWrapper :: Bool, -- True <=> has a wrapper
ifConInfix :: Bool, -- True <=> declared infix
- ifConArgTys :: [IfaceType], -- Arg types
- ifConStricts :: [StrictnessMark], -- Empty (meaning all lazy), or 1-1 corresp with arg types
- ifConFields :: [OccName] } -- ...ditto... (field labels)
- | IfGadtCon {
- ifConOcc :: OccName, -- Constructor name
- ifConTyVars :: [IfaceTvBndr], -- All tyvars
+ ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars
+ ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
+ ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
- ifConResTys :: [IfaceType], -- Result type args
- ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types
-
+ ifConFields :: [OccName], -- ...ditto... (field labels)
+ ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy),
+ -- or 1-1 corresp with arg tys
+
data IfaceInst
- = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with
+ = IfaceInst { ifInstCls :: Name, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance
- ifDFun :: OccName, -- The dfun
+ ifDFun :: Name, -- The dfun
ifOFlag :: OverlapFlag, -- Overlap flag
- ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance
+ ifInstOrph :: Maybe OccName } -- See Note [Orphans]
-- There's always a separate IfaceDecl for the DFun, which gives
-- its IdInfo with its full type and version number.
-- The instance declarations taken together have a version number,
-- If this instance decl is *used*, we'll record a usage on the dfun;
-- and if the head does not change it won't be used if it wasn't before
+data IfaceFamInst
+ = IfaceFamInst { ifFamInstFam :: Name -- Family tycon
+ , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types
+ , ifFamInstTyCon :: IfaceTyCon -- Instance decl
+ }
+
data IfaceRule
= IfaceRule {
ifRuleName :: RuleName,
ifActivation :: Activation,
ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars
- ifRuleHead :: IfaceExtName, -- Head of lhs
+ ifRuleHead :: Name, -- Head of lhs
ifRuleArgs :: [IfaceExpr], -- Args of LHS
ifRuleRhs :: IfaceExpr,
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
+data IfaceAnnotation
+ = IfaceAnnotation {
+ ifAnnotatedTarget :: IfaceAnnTarget,
+ ifAnnotatedValue :: Serialized
+ }
+
+type IfaceAnnTarget = AnnTarget OccName
+
+-- We only serialise the IdDetails of top-level Ids, and even then
+-- we only need a very limited selection. Notably, none of the
+-- implicit ones are needed here, becuase they are not put it
+-- interface files
+
+data IfaceIdDetails
+ = IfVanillaId
+ | IfRecSelId IfaceTyCon Bool
+ | IfDFunId
+
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
| HasInfo [IfaceInfoItem] -- Has info, and here it is
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
- | HsUnfold Activation IfaceExpr
+ | HsInline InlinePragma
+ | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true
+ IfaceUnfolding -- See Note [Expose recursive functions]
| HsNoCafRefs
- | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
- -- for why we want arity here.
- -- NB: we need IfaceExtName (not just OccName) because the worker
- -- can simplify to a function in another module.
+
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
+data IfaceUnfolding
+ = IfCoreUnfold IfaceExpr
+ | IfCompulsory IfaceExpr -- Only used for default methods, in fact
+
+ | IfInlineRule Arity
+ Bool -- OK to inline even if *un*-saturated
+ Bool -- OK to inline even if context is boring
+ IfaceExpr
+
+ | IfWrapper Arity Name -- NB: we need a Name (not just OccName) because the worker
+ -- can simplify to a function in another module.
+
+ | IfDFunUnfold [IfaceExpr]
+
--------------------------------
data IfaceExpr
- = IfaceLcl OccName
- | IfaceExt IfaceExtName
+ = IfaceLcl FastString
+ | IfaceExt Name
| IfaceType IfaceType
| IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted
| IfaceLam IfaceBndr IfaceExpr
| IfaceApp IfaceExpr IfaceExpr
- | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt]
+ | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt]
| IfaceLet IfaceBinding IfaceExpr
| IfaceNote IfaceNote IfaceExpr
+ | IfaceCast IfaceExpr IfaceCoercion
| IfaceLit Literal
| IfaceFCall ForeignCall IfaceType
+ | IfaceTick Module Int
data IfaceNote = IfaceSCC CostCentre
- | IfaceCoerce IfaceType
- | IfaceInlineCall
- | IfaceInlineMe
| IfaceCoreNote String
-type IfaceAlt = (IfaceConAlt, [OccName], IfaceExpr)
- -- Note: OccName, not IfaceBndr (and same with the case binder)
+type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
+ -- Note: FastString, not IfaceBndr (and same with the case binder)
-- We reconstruct the kind/type of the thing from the context
-- thus saving bulk in interface files
data IfaceConAlt = IfaceDefault
- | IfaceDataAlt OccName
+ | IfaceDataAlt Name
| IfaceTupleAlt Boxity
| IfaceLitAlt Literal
data IfaceBinding
- = IfaceNonRec IfaceIdBndr IfaceExpr
- | IfaceRec [(IfaceIdBndr, IfaceExpr)]
+ = IfaceNonRec IfaceLetBndr IfaceExpr
+ | IfaceRec [(IfaceLetBndr, IfaceExpr)]
+
+-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
+-- It's used for *non-top-level* let/rec binders
+-- See Note [IdInfo on nested let-bindings]
+data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
\end{code}
+Note [Expose recursive functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For supercompilation we want to put *all* unfoldings in the interface
+file, even for functions that are recursive (or big). So we need to
+know when an unfolding belongs to a loop-breaker so that we can refrain
+from inlining it (except during supercompilation).
-%************************************************************************
-%* *
-\subsection[HsCore-print]{Printing Core unfoldings}
-%* *
-%************************************************************************
+Note [IdInfo on nested let-bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Occasionally we want to preserve IdInfo on nested let bindings. The one
+that came up was a NOINLINE pragma on a let-binding inside an INLINE
+function. The user (Duncan Coutts) really wanted the NOINLINE control
+to cross the separate compilation boundary.
+
+So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
+Currently we only actually retain InlinePragInfo, but in principle we could
+add strictness etc.
+
+
+Note [Orphans]: the ifInstOrph and ifRuleOrph fields
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If a module contains any "orphans", then its interface file is read
+regardless, so that its instances are not missed.
+
+Roughly speaking, an instance is an orphan if its head (after the =>)
+mentions nothing defined in this module. Functional dependencies
+complicate the situation though. Consider
+
+ module M where { class C a b | a -> b }
+
+and suppose we are compiling module X:
+
+ module X where
+ import M
+ data T = ...
+ instance C Int T where ...
+
+This instance is an orphan, because when compiling a third module Y we
+might get a constraint (C Int v), and we'd want to improve v to T. So
+we must make sure X's instances are loaded, even if we do not directly
+use anything from X.
+
+More precisely, an instance is an orphan iff
+
+ If there are no fundeps, then at least of the names in
+ the instance head is locally defined.
+
+ If there are fundeps, then for every fundep, at least one of the
+ names free in a *non-determined* part of the instance head is
+ defined in this module.
+
+(Note that these conditions hold trivially if the class is locally
+defined.)
+
+Note [Versioning of instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Now consider versioning. If we *use* an instance decl in one compilation,
+we'll depend on the dfun id for that instance, so we'll recompile if it changes.
+But suppose we *don't* (currently) use an instance! We must recompile if
+the instance is changed in such a way that it becomes important. (This would
+only matter with overlapping instances, else the importing module wouldn't have
+compiled before and the recompilation check is irrelevant.)
+
+The is_orph field is set to (Just n) if the instance is not an orphan.
+The 'n' is *any* of the locally-defined names mentioned anywhere in the
+instance head. This name is used for versioning; the instance decl is
+considered part of the defn of this 'n'.
+
+I'm worried about whether this works right if we pick a name from
+a functionally-dependent part of the instance decl. E.g.
+
+ module M where { class C a b | a -> b }
+
+and suppose we are compiling module X:
+
+ module X where
+ import M
+ data S = ...
+ data T = ...
+ instance C S T where ...
+
+If we base the instance verion on T, I'm worried that changing S to S'
+would change T's version, but not S or S'. But an importing module might
+not depend on T, and so might not be recompiled even though the new instance
+(C S' T) might be relevant. I have not been able to make a concrete example,
+and it seems deeply obscure, so I'm going to leave it for now.
+
+
+Note [Versioning of rules]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+A rule that is not an orphan has an ifRuleOrph field of (Just n), where
+n appears on the LHS of the rule; any change in the rule changes the version of n.
------------------------------ Printing IfaceDecl ------------------------------------
\begin{code}
+-- -----------------------------------------------------------------------------
+-- Utils on IfaceSyn
+
+ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
+-- *Excludes* the 'main' name, but *includes* the implicitly-bound names
+-- Deeply revolting, because it has to predict what gets bound,
+-- especially the question of whether there's a wrapper for a datacon
+
+-- N.B. the set of names returned here *must* match the set of
+-- TyThings returned by HscTypes.implicitTyThings, in the sense that
+-- TyThing.getOccName should define a bijection between the two lists.
+-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
+-- The order of the list does not matter.
+ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = []
+
+-- Newtype
+ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfNewTyCon (
+ IfCon { ifConOcc = con_occ }),
+ ifFamInst = famInst})
+ = -- implicit coerion and (possibly) family instance coercion
+ (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
+ -- data constructor and worker (newtypes don't have a wrapper)
+ [con_occ, mkDataConWorkerOcc con_occ]
+
+
+ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
+ ifCons = IfDataTyCon cons,
+ ifFamInst = famInst})
+ = -- (possibly) family instance coercion;
+ -- there is no implicit coercion for non-newtypes
+ famInstCo famInst tc_occ
+ -- for each data constructor in order,
+ -- data constructor, worker, and (possibly) wrapper
+ ++ concatMap dc_occs cons
+ where
+ dc_occs con_decl
+ | has_wrapper = [con_occ, work_occ, wrap_occ]
+ | otherwise = [con_occ, work_occ]
+ where
+ con_occ = ifConOcc con_decl -- DataCon namespace
+ wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
+ work_occ = mkDataConWorkerOcc con_occ -- Id namespace
+ has_wrapper = ifConWrapper con_decl -- This is the reason for
+ -- having the ifConWrapper field!
+
+ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
+ ifSigs = sigs, ifATs = ats })
+ = -- dictionary datatype:
+ -- type constructor
+ tc_occ :
+ -- (possibly) newtype coercion
+ co_occs ++
+ -- data constructor (DataCon namespace)
+ -- data worker (Id namespace)
+ -- no wrapper (class dictionaries never have a wrapper)
+ [dc_occ, dcww_occ] ++
+ -- associated types
+ [ifName at | at <- ats ] ++
+ -- superclass selectors
+ [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
+ -- operation selectors
+ [op | IfaceClassOp op _ _ <- sigs]
+ where
+ n_ctxt = length sc_ctxt
+ n_sigs = length sigs
+ tc_occ = mkClassTyConOcc cls_occ
+ dc_occ = mkClassDataConOcc cls_occ
+ co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
+ | otherwise = []
+ dcww_occ = mkDataConWorkerOcc dc_occ
+ is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+
+ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
+ ifFamInst = famInst})
+ = famInstCo famInst tc_occ
+
+ifaceDeclSubBndrs _ = []
+
+-- coercion for data/newtype family instances
+famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName]
+famInstCo Nothing _ = []
+famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
+
+----------------------------- Printing IfaceDecl ------------------------------
+
instance Outputable IfaceDecl where
ppr = pprIfaceDecl
-pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
+pprIfaceDecl :: IfaceDecl -> SDoc
+pprIfaceDecl (IfaceId {ifName = var, ifType = ty,
+ ifIdDetails = details, ifIdInfo = info})
= sep [ ppr var <+> dcolon <+> ppr ty,
+ nest 2 (ppr details),
nest 2 (ppr info) ]
pprIfaceDecl (IfaceForeign {ifName = tycon})
- = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]
+ = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon]
+
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifSynRhs = Just mono_ty,
+ ifFamInst = mbFamInst})
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
+ 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
-pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, ifVrcs = vrcs})
- = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (vcat [equals <+> ppr mono_ty,
- pprVrcs vrcs])
+pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
+ ifSynRhs = Nothing, ifSynKind = kind })
+ = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars)
+ 4 (dcolon <+> ppr kind)
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
ifTyVars = tyvars, ifCons = condecls,
- ifRec = isrec, ifVrcs = vrcs})
+ ifRec = isrec, ifFamInst = mbFamInst})
= hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
- 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls])
+ 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
+ pprFamily mbFamInst])
where
pp_nd = case condecls of
- IfAbstractTyCon -> ptext SLIT("data")
- IfDataTyCon _ -> ptext SLIT("data")
- IfNewTyCon _ -> ptext SLIT("newtype")
+ IfAbstractTyCon -> ptext (sLit "data")
+ IfOpenDataTyCon -> ptext (sLit "data family")
+ IfDataTyCon _ -> ptext (sLit "data")
+ IfNewTyCon _ -> ptext (sLit "newtype")
pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars,
- ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec})
- = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
- 4 (vcat [pprVrcs vrcs,
- pprRec isrec,
- sep (map ppr sigs)])
+ ifFDs = fds, ifATs = ats, ifSigs = sigs,
+ ifRec = isrec})
+ = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
+ 4 (vcat [pprRec isrec,
+ sep (map ppr ats),
+ sep (map ppr sigs)])
-pprVrcs vrcs = ptext SLIT("Variances") <+> ppr vrcs
-pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
-pprGen True = ptext SLIT("Generics: yes")
-pprGen False = ptext SLIT("Generics: no")
+pprRec :: RecFlag -> SDoc
+pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec
+
+pprGen :: Bool -> SDoc
+pprGen True = ptext (sLit "Generics: yes")
+pprGen False = ptext (sLit "Generics: no")
+
+pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc
+pprFamily Nothing = ptext (sLit "FamilyInstance: none")
+pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst
instance Outputable IfaceClassOp where
ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
-pprIfaceDeclHead context thing tyvars
- = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars]
+pprIfaceDeclHead context thing tyvars
+ = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing),
+ pprIfaceTvBndrs tyvars]
-pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}")
+pp_condecls :: OccName -> IfaceConDecls -> SDoc
+pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}")
pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
- (map (pprIfaceConDecl tc) cs))
-
-pprIfaceConDecl tc (IfVanillaCon {
- ifConOcc = name, ifConInfix = is_infix,
- ifConArgTys = arg_tys,
- ifConStricts = strs, ifConFields = fields })
- = sep [ppr name <+> sep (map pprParendIfaceType arg_tys),
- if is_infix then ptext SLIT("Infix") else empty,
- if null strs then empty
- else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
- if null fields then empty
- else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
-
-pprIfaceConDecl tc (IfGadtCon {
- ifConOcc = name,
- ifConTyVars = tvs, ifConCtxt = ctxt,
- ifConArgTys = arg_tys, ifConResTys = res_tys,
- ifConStricts = strs })
- = sep [ppr name <+> dcolon <+> pprIfaceForAllPart tvs ctxt (ppr con_tau),
- if null strs then empty
- else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs))]
- where
- con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app])
- tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) res_tys
- -- Gruesome, but jsut for debug print
+pp_condecls _ IfOpenDataTyCon = empty
+pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
+ (map (pprIfaceConDecl tc) cs))
+
+pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
+pprIfaceConDecl tc
+ (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap,
+ ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs,
+ ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys,
+ ifConStricts = strs, ifConFields = fields })
+ = sep [main_payload,
+ if is_infix then ptext (sLit "Infix") else empty,
+ if has_wrap then ptext (sLit "HasWrapper") else empty,
+ ppUnless (null strs) $
+ nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr strs)),
+ ppUnless (null fields) $
+ nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))]
+ where
+ main_payload = ppr name <+> dcolon <+>
+ pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
+
+ eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)
+ | (tv,ty) <- eq_spec]
+
+ -- A bit gruesome this, but we can't form the full con_tau, and ppr it,
+ -- because we don't have a Name for the tycon, only an OccName
+ pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
+ (t:ts) -> fsep (t : map (arrow <+>) ts)
+ [] -> panic "pp_con_taus"
+
+ pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
instance Outputable IfaceRule where
ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs })
= sep [hsep [doubleQuotes (ftext name), ppr act,
- ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
- nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
- ptext SLIT("=") <+> ppr rhs])
+ ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
+ nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args),
+ ptext (sLit "=") <+> ppr rhs])
]
instance Outputable IfaceInst where
ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag,
ifInstCls = cls, ifInstTys = mb_tcs})
- = hang (ptext SLIT("instance") <+> ppr flag
- <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs))
+ = hang (ptext (sLit "instance") <+> ppr flag
+ <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
- where
- ppr_mb Nothing = dot
- ppr_mb (Just tc) = ppr tc
+
+instance Outputable IfaceFamInst where
+ ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
+ ifFamInstTyCon = tycon_id})
+ = hang (ptext (sLit "family instance") <+>
+ ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
+ 2 (equals <+> ppr tycon_id)
+
+ppr_rough :: Maybe IfaceTyCon -> SDoc
+ppr_rough Nothing = dot
+ppr_rough (Just tc) = ppr tc
\end{code}
instance Outputable IfaceExpr where
ppr e = pprIfaceExpr noParens e
+pprParendIfaceExpr :: IfaceExpr -> SDoc
+pprParendIfaceExpr = pprIfaceExpr parens
+
pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
-- The function adds parens in context that need
-- an atomic value (e.g. function args)
-pprIfaceExpr add_par (IfaceLcl v) = ppr v
-pprIfaceExpr add_par (IfaceExt v) = ppr v
-pprIfaceExpr add_par (IfaceLit l) = ppr l
-pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
-pprIfaceExpr add_par (IfaceType ty) = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _ (IfaceLcl v) = ppr v
+pprIfaceExpr _ (IfaceExt v) = ppr v
+pprIfaceExpr _ (IfaceLit l) = ppr l
+pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
+pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
+pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty
pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
-pprIfaceExpr add_par (IfaceTuple c as) = tupleParens c (interpp'SP as)
+pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as)
pprIfaceExpr add_par e@(IfaceLam _ _)
= add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
collect bs (IfaceLam b e) = collect (b:bs) e
collect bs e = (reverse bs, e)
--- gaw 2004
pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
--- gaw 2004
- = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+ <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
pprIfaceExpr noParens rhs <+> char '}'])
--- gaw 2004
pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
--- gaw 2004
- = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of")
+ = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
+ <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
<+> ppr bndr <+> char '{',
nest 2 (sep (map ppr_alt alts)) <+> char '}'])
+pprIfaceExpr _ (IfaceCast expr co)
+ = sep [pprParendIfaceExpr expr,
+ nest 2 (ptext (sLit "`cast`")),
+ pprParendIfaceType co]
+
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
- = add_par (sep [ptext SLIT("let {"),
+ = add_par (sep [ptext (sLit "let {"),
nest 2 (ppr_bind (b, rhs)),
- ptext SLIT("} in"),
+ ptext (sLit "} in"),
pprIfaceExpr noParens body])
pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
- = add_par (sep [ptext SLIT("letrec {"),
+ = add_par (sep [ptext (sLit "letrec {"),
nest 2 (sep (map ppr_bind pairs)),
- ptext SLIT("} in"),
+ ptext (sLit "} in"),
pprIfaceExpr noParens body])
-pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)
+pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body)
+ppr_alt :: (IfaceConAlt, [FastString], IfaceExpr) -> SDoc
ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
arrow <+> pprIfaceExpr noParens rhs]
+ppr_con_bs :: IfaceConAlt -> [FastString] -> SDoc
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
-ppr_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty,
- equals <+> pprIfaceExpr noParens rhs]
+ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
+ppr_bind (IfLetBndr b ty info, rhs)
+ = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
+ equals <+> pprIfaceExpr noParens rhs]
------------------
-pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
-pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
+pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc
+pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args)
+pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args)
------------------
instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
- ppr (IfaceCoerce ty) = ptext SLIT("__coerce") <+> pprParendIfaceType ty
- ppr IfaceInlineCall = ptext SLIT("__inline_call")
- ppr IfaceInlineMe = ptext SLIT("__inline_me")
- ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+ ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s)
+
instance Outputable IfaceConAlt where
- ppr IfaceDefault = text "DEFAULT"
+ ppr IfaceDefault = text "DEFAULT"
ppr (IfaceLitAlt l) = ppr l
ppr (IfaceDataAlt d) = ppr d
- ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt"
- -- IfaceTupleAlt is handled by the case-alternative printer
+ ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
+ -- IfaceTupleAlt is handled by the case-alternative printer
------------------
-instance Outputable IfaceIdInfo where
- ppr NoInfo = empty
- ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}")
-
-ppr_hs_info (HsUnfold prag unf) = sep [ptext SLIT("Unfolding: ") <> ppr prag,
- parens (pprIfaceExpr noParens unf)]
-ppr_hs_info (HsArity arity) = ptext SLIT("Arity:") <+> int arity
-ppr_hs_info (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
-ppr_hs_info HsNoCafRefs = ptext SLIT("HasNoCafRefs")
-ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
-\end{code}
-
+instance Outputable IfaceIdDetails where
+ ppr IfVanillaId = empty
+ ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
+ <+> if b then ptext (sLit "<naughty>") else empty
+ ppr IfDFunId = ptext (sLit "DFunId")
-%************************************************************************
-%* *
- Converting things to their Iface equivalents
-%* *
-%************************************************************************
-
-
-\begin{code}
-tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
--- Assumption: the thing is already tidied, so that locally-bound names
--- (lambdas, for-alls) already have non-clashing OccNames
--- Reason: Iface stuff uses OccNames, and the conversion here does
--- not do tidying on the way
-tyThingToIfaceDecl ext (AnId id)
- = IfaceId { ifName = getOccName id,
- ifType = toIfaceType ext (idType id),
- ifIdInfo = info }
- where
- info = case toIfaceIdInfo ext (idInfo id) of
- [] -> NoInfo
- items -> HasInfo items
-
-tyThingToIfaceDecl ext (AClass clas)
- = IfaceClass { ifCtxt = toIfaceContext ext sc_theta,
- ifName = getOccName clas,
- ifTyVars = toIfaceTvBndrs clas_tyvars,
- ifFDs = map toIfaceFD clas_fds,
- ifSigs = map toIfaceClassOp op_stuff,
- ifRec = boolToRecFlag (isRecursiveTyCon tycon),
- ifVrcs = tyConArgVrcs tycon }
- where
- (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas
- tycon = classTyCon clas
-
- toIfaceClassOp (sel_id, def_meth)
- = ASSERT(sel_tyvars == clas_tyvars)
- IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty)
- where
- -- Be careful when splitting the type, because of things
- -- like class Foo a where
- -- op :: (?x :: String) => a -> a
- -- and class Baz a where
- -- op :: (Ord a) => a -> a
- (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)
- op_ty = funResultTy rho_ty
-
- toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2)
-
-tyThingToIfaceDecl ext (ATyCon tycon)
- | isSynTyCon tycon
- = IfaceSyn { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs tyvars,
- ifVrcs = tyConArgVrcs tycon,
- ifSynRhs = toIfaceType ext syn_ty }
-
- | isAlgTyCon tycon
- = IfaceData { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs tyvars,
- ifCtxt = toIfaceContext ext (tyConStupidTheta tycon),
- ifCons = ifaceConDecls (algTyConRhs tycon),
- ifRec = boolToRecFlag (isRecursiveTyCon tycon),
- ifVrcs = tyConArgVrcs tycon,
- ifGeneric = tyConHasGenerics tycon }
-
- | isForeignTyCon tycon
- = IfaceForeign { ifName = getOccName tycon,
- ifExtName = tyConExtName tycon }
-
- | isPrimTyCon tycon || isFunTyCon tycon
- -- Needed in GHCi for ':info Int#', for example
- = IfaceData { ifName = getOccName tycon,
- ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars),
- ifCtxt = [],
- ifCons = IfAbstractTyCon,
- ifGeneric = False,
- ifRec = NonRecursive,
- ifVrcs = tyConArgVrcs tycon }
-
- | otherwise = pprPanic "toIfaceDecl" (ppr tycon)
- where
- tyvars = tyConTyVars tycon
- syn_ty = synTyConRhs tycon
-
- ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con)
- ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)
- ifaceConDecls AbstractTyCon = IfAbstractTyCon
- -- The last case happens when a TyCon has been trimmed during tidying
- -- Furthermore, tyThingToIfaceDecl is also used
- -- in TcRnDriver for GHCi, when browsing a module, in which case the
- -- AbstractTyCon case is perfectly sensible.
-
- ifaceConDecl data_con
- | isVanillaDataCon data_con
- = IfVanillaCon {ifConOcc = getOccName (dataConName data_con),
- ifConInfix = dataConIsInfix data_con,
- ifConArgTys = map (toIfaceType ext) arg_tys,
- ifConStricts = strict_marks,
- ifConFields = map getOccName field_labels }
- | otherwise
- = IfGadtCon { ifConOcc = getOccName (dataConName data_con),
- ifConTyVars = toIfaceTvBndrs tyvars,
- ifConCtxt = toIfaceContext ext theta,
- ifConArgTys = map (toIfaceType ext) arg_tys,
- ifConResTys = map (toIfaceType ext) res_tys,
- ifConStricts = strict_marks }
- where
- (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con
- field_labels = dataConFieldLabels data_con
- strict_marks = dataConStrictMarks data_con
-
-tyThingToIfaceDecl ext (ADataCon dc)
- = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier
-
-
---------------------------
-instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst
-instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag,
- is_cls = cls, is_tcs = mb_tcs,
- is_orph = orph })
- = IfaceInst { ifDFun = getOccName dfun_id,
- ifOFlag = oflag,
- ifInstCls = ext_lhs cls,
- ifInstTys = map do_rough mb_tcs,
- ifInstOrph = orph }
- where
- do_rough Nothing = Nothing
- do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n)
-
---------------------------
-toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem]
-toIfaceIdInfo ext id_info
- = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo,
- wrkr_hsinfo, unfold_hsinfo]
- where
- ------------ Arity --------------
- arity_info = arityInfo id_info
- arity_hsinfo | arity_info == 0 = Nothing
- | otherwise = Just (HsArity arity_info)
-
- ------------ Caf Info --------------
- caf_info = cafInfo id_info
- caf_hsinfo = case caf_info of
- NoCafRefs -> Just HsNoCafRefs
- _other -> Nothing
-
- ------------ Strictness --------------
- -- No point in explicitly exporting TopSig
- strict_hsinfo = case newStrictnessInfo id_info of
- Just sig | not (isTopSig sig) -> Just (HsStrictness sig)
- _other -> Nothing
-
- ------------ Worker --------------
- work_info = workerInfo id_info
- has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
- wrkr_hsinfo = case work_info of
- HasWorker work_id wrap_arity ->
- Just (HsWorker (ext (idName work_id)) wrap_arity)
- NoWorker -> Nothing
-
- ------------ Unfolding --------------
- -- The unfolding is redundant if there is a worker
- unfold_info = unfoldingInfo id_info
- inline_prag = inlinePragInfo id_info
- rhs = unfoldingTemplate unfold_info
- unfold_hsinfo | neverUnfold unfold_info
- || has_worker = Nothing
- | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs))
-
---------------------------
-coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names
- -> (Name -> IfaceExtName) -- For the RHS names
- -> CoreRule -> IfaceRule
-coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn})
- = pprTrace "toHsRule: builtin" (ppr fn) $
- bogusIfaceRule (mkIfaceExtName fn)
-
-coreRuleToIfaceRule ext_lhs ext_rhs
- (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs,
- ru_args = args, ru_rhs = rhs, ru_orph = orph })
- = IfaceRule { ifRuleName = name, ifActivation = act,
- ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs,
- ifRuleHead = ext_lhs fn,
- ifRuleArgs = map do_arg args,
- ifRuleRhs = toIfaceExpr ext_rhs rhs,
- ifRuleOrph = orph }
- where
- -- For type args we must remove synonyms from the outermost
- -- level. Reason: so that when we read it back in we'll
- -- construct the same ru_rough field as we have right now;
- -- see tcIfaceRule
- do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty))
- do_arg arg = toIfaceExpr ext_lhs arg
-
-bogusIfaceRule :: IfaceExtName -> IfaceRule
-bogusIfaceRule id_name
- = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive,
- ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],
- ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing }
-
----------------------
-toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr
-toIfaceExpr ext (Var v) = toIfaceVar ext v
-toIfaceExpr ext (Lit l) = IfaceLit l
-toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty)
-toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b)
-toIfaceExpr ext (App f a) = toIfaceApp ext f [a]
--- gaw 2004
-toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (toIfaceType ext ty) (map (toIfaceAlt ext) as)
-toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e)
-toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e)
-
----------------------
-toIfaceNote ext (SCC cc) = IfaceSCC cc
-toIfaceNote ext (Coerce t1 _) = IfaceCoerce (toIfaceType ext t1)
-toIfaceNote ext InlineCall = IfaceInlineCall
-toIfaceNote ext InlineMe = IfaceInlineMe
-toIfaceNote ext (CoreNote s) = IfaceCoreNote s
-
----------------------
-toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r)
-toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs]
-
----------------------
-toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map getOccName bs, toIfaceExpr ext r)
-
----------------------
-toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc)
- | otherwise = IfaceDataAlt (getOccName dc)
- where
- tc = dataConTyCon dc
-
-toIfaceCon (LitAlt l) = IfaceLitAlt l
-toIfaceCon DEFAULT = IfaceDefault
-
----------------------
-toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as)
-toIfaceApp ext (Var v) as
- = case isDataConWorkId_maybe v of
- -- We convert the *worker* for tuples into IfaceTuples
- Just dc | isTupleTyCon tc && saturated
- -> IfaceTuple (tupleTyConBoxity tc) tup_args
- where
- val_args = dropWhile isTypeArg as
- saturated = val_args `lengthIs` idArity v
- tup_args = map (toIfaceExpr ext) val_args
- tc = dataConTyCon dc
-
- other -> mkIfaceApps ext (toIfaceVar ext v) as
-
-toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as
-
-mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as
-
----------------------
-toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr
-toIfaceVar ext v
- | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v))
- -- Foreign calls have special syntax
- | isExternalName name = IfaceExt (ext name)
- | otherwise = IfaceLcl (nameOccName name)
+instance Outputable IfaceIdInfo where
+ ppr NoInfo = empty
+ ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}")
+
+instance Outputable IfaceInfoItem where
+ ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)"))
+ <> colon <+> ppr unf
+ ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag
+ ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
+ ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
+ ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
+
+instance Outputable IfaceUnfolding where
+ ppr (IfCompulsory e) = ptext (sLit "<compulsory>") <+> parens (ppr e)
+ ppr (IfCoreUnfold e) = parens (ppr e)
+ ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok),
+ pprParendIfaceExpr e]
+ ppr (IfWrapper a wkr) = ptext (sLit "Worker:") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a)
+ ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") <+> brackets (pprWithCommas pprParendIfaceExpr ns)
+
+
+-- -----------------------------------------------------------------------------
+-- Finding the Names in IfaceSyn
+
+-- This is used for dependency analysis in MkIface, so that we
+-- fingerprint a declaration before the things that depend on it. It
+-- is specific to interface-file fingerprinting in the sense that we
+-- don't collect *all* Names: for example, the DFun of an instance is
+-- recorded textually rather than by its fingerprint when
+-- fingerprinting the instance, so DFuns are not dependencies.
+
+freeNamesIfDecl :: IfaceDecl -> NameSet
+freeNamesIfDecl (IfaceId _s t d i) =
+ freeNamesIfType t &&&
+ freeNamesIfIdInfo i &&&
+ freeNamesIfIdDetails d
+freeNamesIfDecl IfaceForeign{} =
+ emptyNameSet
+freeNamesIfDecl d@IfaceData{} =
+ freeNamesIfTvBndrs (ifTyVars d) &&&
+ freeNamesIfTcFam (ifFamInst d) &&&
+ freeNamesIfContext (ifCtxt d) &&&
+ freeNamesIfConDecls (ifCons d)
+freeNamesIfDecl d@IfaceSyn{} =
+ freeNamesIfTvBndrs (ifTyVars d) &&&
+ freeNamesIfSynRhs (ifSynRhs d) &&&
+ freeNamesIfTcFam (ifFamInst d)
+freeNamesIfDecl d@IfaceClass{} =
+ freeNamesIfTvBndrs (ifTyVars d) &&&
+ freeNamesIfContext (ifCtxt d) &&&
+ freeNamesIfDecls (ifATs d) &&&
+ fnList freeNamesIfClsSig (ifSigs d)
+
+freeNamesIfIdDetails :: IfaceIdDetails -> NameSet
+freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc
+freeNamesIfIdDetails _ = emptyNameSet
+
+-- All other changes are handled via the version info on the tycon
+freeNamesIfSynRhs :: Maybe IfaceType -> NameSet
+freeNamesIfSynRhs (Just ty) = freeNamesIfType ty
+freeNamesIfSynRhs Nothing = emptyNameSet
+
+freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet
+freeNamesIfTcFam (Just (tc,tys)) =
+ freeNamesIfTc tc &&& fnList freeNamesIfType tys
+freeNamesIfTcFam Nothing =
+ emptyNameSet
+
+freeNamesIfContext :: IfaceContext -> NameSet
+freeNamesIfContext = fnList freeNamesIfPredType
+
+freeNamesIfDecls :: [IfaceDecl] -> NameSet
+freeNamesIfDecls = fnList freeNamesIfDecl
+
+freeNamesIfClsSig :: IfaceClassOp -> NameSet
+freeNamesIfClsSig (IfaceClassOp _n _dm ty) = freeNamesIfType ty
+
+freeNamesIfConDecls :: IfaceConDecls -> NameSet
+freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c
+freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c
+freeNamesIfConDecls _ = emptyNameSet
+
+freeNamesIfConDecl :: IfaceConDecl -> NameSet
+freeNamesIfConDecl c =
+ freeNamesIfTvBndrs (ifConUnivTvs c) &&&
+ freeNamesIfTvBndrs (ifConExTvs c) &&&
+ freeNamesIfContext (ifConCtxt c) &&&
+ fnList freeNamesIfType (ifConArgTys c) &&&
+ fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints
+
+freeNamesIfPredType :: IfacePredType -> NameSet
+freeNamesIfPredType (IfaceClassP cl tys) =
+ unitNameSet cl &&& fnList freeNamesIfType tys
+freeNamesIfPredType (IfaceIParam _n ty) =
+ freeNamesIfType ty
+freeNamesIfPredType (IfaceEqPred ty1 ty2) =
+ freeNamesIfType ty1 &&& freeNamesIfType ty2
+
+freeNamesIfType :: IfaceType -> NameSet
+freeNamesIfType (IfaceTyVar _) = emptyNameSet
+freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st
+freeNamesIfType (IfaceTyConApp tc ts) =
+ freeNamesIfTc tc &&& fnList freeNamesIfType ts
+freeNamesIfType (IfaceForAllTy tv t) =
+ freeNamesIfTvBndr tv &&& freeNamesIfType t
+freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
+
+freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
+freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
+
+freeNamesIfBndr :: IfaceBndr -> NameSet
+freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b
+freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b
+
+freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
+-- Remember IfaceLetBndr is used only for *nested* bindings
+-- The cut-down IdInfo never contains any Names, but the type may!
+freeNamesIfLetBndr (IfLetBndr _name ty _info) = freeNamesIfType ty
+
+freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
+freeNamesIfTvBndr (_fs,k) = freeNamesIfType k
+ -- kinds can have Names inside, when the Kind is an equality predicate
+
+freeNamesIfIdBndr :: IfaceIdBndr -> NameSet
+freeNamesIfIdBndr = freeNamesIfTvBndr
+
+freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
+freeNamesIfIdInfo NoInfo = emptyNameSet
+freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i
+
+freeNamesItem :: IfaceInfoItem -> NameSet
+freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
+freeNamesItem _ = emptyNameSet
+
+freeNamesIfUnfold :: IfaceUnfolding -> NameSet
+freeNamesIfUnfold (IfCoreUnfold e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e
+freeNamesIfUnfold (IfWrapper _ v) = unitNameSet v
+freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs
+
+freeNamesIfExpr :: IfaceExpr -> NameSet
+freeNamesIfExpr (IfaceExt v) = unitNameSet v
+freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
+freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
+freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
+freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a
+freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co
+freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r
+
+freeNamesIfExpr (IfaceCase s _ ty alts)
+ = freeNamesIfExpr s
+ &&& fnList fn_alt alts &&& fn_cons alts
+ &&& freeNamesIfType ty
where
- name = idName v
-\end{code}
-
-
-%************************************************************************
-%* *
- Equality, for interface file version generaion only
-%* *
-%************************************************************************
-
-Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is
-EqBut, which gives the set of *locally-defined* things whose version must be equal
-for the whole thing to be equal. So the key function is eqIfExt, which compares
-IfaceExtNames.
+ fn_alt (_con,_bs,r) = freeNamesIfExpr r
-Of course, equality is also done modulo alpha conversion.
-
-\begin{code}
-data IfaceEq
- = Equal -- Definitely exactly the same
- | NotEqual -- Definitely different
- | EqBut OccSet -- The same provided these local things have not changed
-
-bool :: Bool -> IfaceEq
-bool True = Equal
-bool False = NotEqual
-
-zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
-zapEq (EqBut _) = Equal
-zapEq other = other
-
-(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
-Equal &&& x = x
-NotEqual &&& x = NotEqual
-EqBut occs &&& Equal = EqBut occs
-EqBut occs &&& NotEqual = NotEqual
-EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2)
-
----------------------
-eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq
--- This function is the core of the EqBut stuff
-eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2)
-eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2)
-eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1)
-eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1)
-eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1)
-eqIfExt n1 n2 = NotEqual
-\end{code}
+ -- Depend on the data constructors. Just one will do!
+ -- Note [Tracking data constructors]
+ fn_cons [] = emptyNameSet
+ fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts
+ fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con
+ fn_cons (_ : _ ) = emptyNameSet
+freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)
+ = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body
-\begin{code}
----------------------
-eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
-eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
- = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)
-
-eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
- = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)
-
-eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
- = bool (ifName d1 == ifName d2 &&
- ifRec d1 == ifRec d2 &&
- ifVrcs d1 == ifVrcs d2 &&
- ifGeneric d1 == ifGeneric d2) &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- eq_hsCD env (ifCons d1) (ifCons d2)
- )
- -- The type variables of the data type do not scope
- -- over the constructors (any more), but they do scope
- -- over the stupid context in the IfaceConDecls
-
-eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
- = bool (ifName d1 == ifName d2) &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
- )
-
-eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
- = bool (ifName d1 == ifName d2 &&
- ifRec d1 == ifRec d2 &&
- ifVrcs d1 == ifVrcs d2) &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
- eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
- )
-
-eqIfDecl _ _ = NotEqual -- default case
-
--- Helper
-eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
-eqWith = eq_ifTvBndrs emptyEqEnv
-
------------------------
-eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2)
--- All other changes are handled via the version info on the dfun
-
-eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
- (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
- = bool (n1==n2 && a1==a2 && o1 == o2) &&&
- f1 `eqIfExt` f2 &&&
- eq_ifBndrs emptyEqEnv bs1 bs2 (\env ->
- zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
- -- zapEq: for the LHSs, ignore the EqBut part
- eq_ifaceExpr env rhs1 rhs2)
-
-eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2)
- = eqListBy (eq_ConDecl env) c1 c2
-
-eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2
-eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal
-eq_hsCD env d1 d2 = NotEqual
-
-eq_ConDecl env c1@(IfVanillaCon {}) c2@(IfVanillaCon {})
- = bool (ifConOcc c1 == ifConOcc c2 &&
- ifConInfix c1 == ifConInfix c2 &&
- ifConStricts c1 == ifConStricts c2 &&
- ifConFields c1 == ifConFields c2) &&&
- eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)
-
-eq_ConDecl env c1@(IfGadtCon {}) c2@(IfGadtCon {})
- = bool (ifConOcc c1 == ifConOcc c2 &&
- ifConStricts c1 == ifConStricts c2) &&&
- eq_ifTvBndrs env (ifConTyVars c1) (ifConTyVars c2) (\ env ->
- eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
- eq_ifTypes env (ifConResTys c1) (ifConResTys c2) &&&
- eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2))
-
-eq_ConDecl env c1 c2 = NotEqual
-
-eq_hsFD env (ns1,ms1) (ns2,ms2)
- = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2
-
-eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
- = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
-\end{code}
-
-
-\begin{code}
------------------
-eqIfIdInfo NoInfo NoInfo = Equal
-eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
-eqIfIdInfo i1 i2 = NotEqual
-
-eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
-eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
-eq_item (HsUnfold a1 u1) (HsUnfold a2 u2) = bool (a1 == a2) &&& eq_ifaceExpr emptyEqEnv u1 u2
-eq_item HsNoCafRefs HsNoCafRefs = Equal
-eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
-eq_item _ _ = NotEqual
-
------------------
-eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
-eq_ifaceExpr env (IfaceLcl v1) (IfaceLcl v2) = eqIfOcc env v1 v2
-eq_ifaceExpr env (IfaceExt v1) (IfaceExt v2) = eqIfExt v1 v2
-eq_ifaceExpr env (IfaceLit l1) (IfaceLit l2) = bool (l1 == l2)
-eq_ifaceExpr env (IfaceFCall c1 ty1) (IfaceFCall c2 ty2) = bool (c1==c2) &&& eq_ifType env ty1 ty2
-eq_ifaceExpr env (IfaceType ty1) (IfaceType ty2) = eq_ifType env ty1 ty2
-eq_ifaceExpr env (IfaceTuple n1 as1) (IfaceTuple n2 as2) = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
-eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
-eq_ifaceExpr env (IfaceApp f1 a1) (IfaceApp f2 a2) = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
-eq_ifaceExpr env (IfaceNote n1 r1) (IfaceNote n2 r2) = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2
-
-eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
- = eq_ifaceExpr env s1 s2 &&&
- eq_ifType env ty1 ty2 &&&
- eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
+freeNamesIfExpr (IfaceLet (IfaceRec as) x)
+ = fnList fn_pair as &&& freeNamesIfExpr x
where
- eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
- = bool (eq_ifaceConAlt c1 c2) &&&
- eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)
+ fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs
-eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
- = eq_ifaceExpr env r1 r2 &&& eq_ifIdBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
+freeNamesIfExpr _ = emptyNameSet
-eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
- = eq_ifIdBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
- where
- (bs1,rs1) = unzip as1
- (bs2,rs2) = unzip as2
-
-
-eq_ifaceExpr env _ _ = NotEqual
-
------------------
-eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
-eq_ifaceConAlt IfaceDefault IfaceDefault = True
-eq_ifaceConAlt (IfaceDataAlt n1) (IfaceDataAlt n2) = n1==n2
-eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2) = c1==c2
-eq_ifaceConAlt (IfaceLitAlt l1) (IfaceLitAlt l2) = l1==l2
-eq_ifaceConAlt _ _ = False
-
------------------
-eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
-eq_ifaceNote env (IfaceSCC c1) (IfaceSCC c2) = bool (c1==c2)
-eq_ifaceNote env (IfaceCoerce t1) (IfaceCoerce t2) = eq_ifType env t1 t2
-eq_ifaceNote env IfaceInlineCall IfaceInlineCall = Equal
-eq_ifaceNote env IfaceInlineMe IfaceInlineMe = Equal
-eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
-eq_ifaceNote env _ _ = NotEqual
-\end{code}
-\begin{code}
----------------------
-eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2
-
--------------------
-eq_ifType env (IfaceTyVar n1) (IfaceTyVar n2) = eqIfOcc env n1 n2
-eq_ifType env (IfaceAppTy s1 t1) (IfaceAppTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
-eq_ifType env (IfacePredTy st1) (IfacePredTy st2) = eq_ifPredType env st1 st2
-eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
-eq_ifType env (IfaceForAllTy tv1 t1) (IfaceForAllTy tv2 t2) = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
-eq_ifType env (IfaceFunTy s1 t1) (IfaceFunTy s2 t2) = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
-eq_ifType env _ _ = NotEqual
-
--------------------
-eq_ifTypes env = eqListBy (eq_ifType env)
-
--------------------
-eq_ifContext env a b = eqListBy (eq_ifPredType env) a b
-
--------------------
-eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&& eq_ifTypes env tys1 tys2
-eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2) = bool (n1 == n2) &&& eq_ifType env ty1 ty2
-eq_ifPredType env _ _ = NotEqual
-
--------------------
-eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
-eqIfTc IfaceIntTc IfaceIntTc = Equal
-eqIfTc IfaceCharTc IfaceCharTc = Equal
-eqIfTc IfaceBoolTc IfaceBoolTc = Equal
-eqIfTc IfaceListTc IfaceListTc = Equal
-eqIfTc IfacePArrTc IfacePArrTc = Equal
-eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
-eqIfTc _ _ = NotEqual
-\end{code}
+freeNamesIfTc :: IfaceTyCon -> NameSet
+freeNamesIfTc (IfaceTc tc) = unitNameSet tc
+-- ToDo: shouldn't we include IfaceIntTc & co.?
+freeNamesIfTc _ = emptyNameSet
------------------------------------------------------------
- Support code for equality checking
------------------------------------------------------------
+freeNamesIfRule :: IfaceRule -> NameSet
+freeNamesIfRule (IfaceRule _n _a bs f es rhs _o)
+ = unitNameSet f &&&
+ fnList freeNamesIfBndr bs &&&
+ fnList freeNamesIfExpr es &&&
+ freeNamesIfExpr rhs
-\begin{code}
-------------------------------------
-type EqEnv = OccEnv OccName -- Tracks the mapping from L-variables to R-variables
-
-eqIfOcc :: EqEnv -> OccName -> OccName -> IfaceEq
-eqIfOcc env n1 n2 = case lookupOccEnv env n1 of
- Just n1 -> bool (n1 == n2)
- Nothing -> bool (n1 == n2)
-
-extendEqEnv :: EqEnv -> OccName -> OccName -> EqEnv
-extendEqEnv env n1 n2 | n1 == n2 = env
- | otherwise = extendOccEnv env n1 n2
-
-emptyEqEnv :: EqEnv
-emptyEqEnv = emptyOccEnv
-
-------------------------------------
-type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
-
-eq_ifNakedBndr :: ExtEnv OccName
-eq_ifBndr :: ExtEnv IfaceBndr
-eq_ifTvBndr :: ExtEnv IfaceTvBndr
-eq_ifIdBndr :: ExtEnv IfaceIdBndr
-
-eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)
-
-eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
-eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
-eq_ifBndr _ _ _ _ = NotEqual
-
-eq_ifTvBndr env (v1, k1) (v2, k2) k = bool (k1 == k2) &&& k (extendEqEnv env v1 v2)
-eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)
-
-eq_ifBndrs :: ExtEnv [IfaceBndr]
-eq_ifIdBndrs :: ExtEnv [IfaceIdBndr]
-eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
-eq_ifNakedBndrs :: ExtEnv [OccName]
-eq_ifBndrs = eq_bndrs_with eq_ifBndr
-eq_ifIdBndrs = eq_bndrs_with eq_ifIdBndr
-eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
-eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
-
-eq_bndrs_with eq env [] [] k = k env
-eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
-eq_bndrs_with eq env _ _ _ = NotEqual
-\end{code}
+-- helpers
+(&&&) :: NameSet -> NameSet -> NameSet
+(&&&) = unionNameSets
-\begin{code}
-eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
-eqListBy eq [] [] = Equal
-eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
-eqListBy eq xs ys = NotEqual
-
-eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
-eqMaybeBy eq Nothing Nothing = Equal
-eqMaybeBy eq (Just x) (Just y) = eq x y
-eqMaybeBy eq x y = NotEqual
+fnList :: (a -> NameSet) -> [a] -> NameSet
+fnList f = foldr (&&&) emptyNameSet . map f
\end{code}
+
+Note [Tracking data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a case expression
+ case e of { C a -> ...; ... }
+You might think that we don't need to include the datacon C
+in the free names, because its type will probably show up in
+the free names of 'e'. But in rare circumstances this may
+not happen. Here's the one that bit me:
+
+ module DynFlags where
+ import {-# SOURCE #-} Packages( PackageState )
+ data DynFlags = DF ... PackageState ...
+
+ module Packages where
+ import DynFlags
+ data PackageState = PS ...
+ lookupModule (df :: DynFlags)
+ = case df of
+ DF ...p... -> case p of
+ PS ... -> ...
+
+Now, lookupModule depends on DynFlags, but the transitive dependency
+on the *locally-defined* type PackageState is not visible. We need
+to take account of the use of the data constructor PS in the pattern match.