%
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
--- for details
-
module IfaceSyn (
module IfaceType, -- Re-export all this
IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
- IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
+ IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceInst(..), IfaceFamInst(..),
-- Misc
ifaceDeclSubBndrs, visibleIfConDecls,
- -- Equality
- GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
- eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
-
+ -- Free Names
+ freeNamesIfDecl, freeNamesIfRule,
+
-- Pretty printing
pprIfaceExpr, pprIfaceDeclHead
) where
#include "HsVersions.h"
-import CoreSyn
import IfaceType
import NewDemand
+import Annotations
import Class
-import UniqFM
import NameSet
import Name
import CostCentre
import Literal
import ForeignCall
+import Serialized
import BasicTypes
import Outputable
import FastString
import Data.Maybe
infixl 3 &&&
-infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
\end{code}
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
- ifOpenSyn :: Bool, -- Is an open family?
- ifSynRhs :: IfaceType, -- Type for an ordinary
- -- synonym and kind for an
- -- open family
- ifFamInst :: Maybe (IfaceTyCon, [IfaceType])
+ 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
ifRuleOrph :: Maybe OccName -- Just like IfaceInst
}
+data IfaceAnnotation
+ = IfaceAnnotation {
+ ifAnnotatedTarget :: IfaceAnnTarget,
+ ifAnnotatedValue :: Serialized
+ }
+
+type IfaceAnnTarget = AnnTarget OccName
+
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
| HasInfo [IfaceInfoItem] -- Has info, and here it is
Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Occasionally we want to preserve IdInfo on nested let bindings The one
+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.
-- Deeply revolting, because it has to predict what gets bound,
-- especially the question of whether there's a wrapper for a datacon
-ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ,
- ifSigs = sigs, ifATs = ats })
- = co_occs ++
- [tc_occ, dc_occ, dcww_occ] ++
- [op | IfaceClassOp op _ _ <- sigs] ++
- [ifName at | at <- ats ] ++
- [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]]
- 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 -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker
- | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper
- is_newtype = n_sigs + n_ctxt == 1 -- Sigh
+-- 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} = []
-ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}
- = []
-- Newtype
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
- ifCons = IfNewTyCon (
- IfCon { ifConOcc = con_occ,
- ifConFields = fields
- }),
- ifFamInst = famInst})
- = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ]
- ++ famInstCo famInst tc_occ
+ ifCons = IfNewTyCon (
+ IfCon { ifConOcc = con_occ,
+ ifConFields = fields
+ }),
+ ifFamInst = famInst})
+ = -- fields (names of selectors)
+ fields ++
+ -- 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})
- = nub (concatMap ifConFields cons) -- Eliminate duplicate fields
- ++ concatMap dc_occs cons
+ = -- fields (names of selectors)
+ nub (concatMap ifConFields cons) -- Eliminate duplicate fields
+ -- (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
- strs = ifConStricts con_decl
- wrap_occ = mkDataConWrapperOcc con_occ
- work_occ = mkDataConWorkerOcc con_occ
+ con_occ = ifConOcc con_decl -- DataCon namespace
+ wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace
+ work_occ = mkDataConWorkerOcc con_occ -- Id namespace
+ strs = ifConStricts con_decl
has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh)
|| not (null . ifConEqSpec $ con_decl)
|| isJust famInst
-- ToDo: may miss strictness in existential dicts
-ifaceDeclSubBndrs _other = []
+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 Nothing baseOcc = []
+famInstCo :: Maybe (IfaceTyCon, [IfaceType]) -> OccName -> [OccName]
+famInstCo Nothing _ = []
famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]
----------------------------- Printing IfaceDecl ------------------------------
instance Outputable IfaceDecl where
ppr = pprIfaceDecl
+pprIfaceDecl :: IfaceDecl -> SDoc
pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
= sep [ ppr var <+> dcolon <+> ppr ty,
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,
- ifOpenSyn = False, ifSynRhs = mono_ty,
+ ifSynRhs = Just mono_ty,
ifFamInst = mbFamInst})
- = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
+ = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars)
4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars,
- ifOpenSyn = True, ifSynRhs = mono_ty})
- = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
- 4 (dcolon <+> ppr mono_ty)
+ 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,
pprFamily mbFamInst])
where
pp_nd = case condecls of
- IfAbstractTyCon -> ptext SLIT("data")
- IfOpenDataTyCon -> ptext SLIT("data family")
- 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, ifATs = ats, ifSigs = sigs,
ifRec = isrec})
- = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
+ = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
4 (vcat [pprRec isrec,
sep (map ppr ats),
sep (map ppr sigs)])
-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 Nothing = ptext SLIT("FamilyInstance: none")
-pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
+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
= 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 IfOpenDataTyCon = empty
-pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
+pp_condecls _ IfOpenDataTyCon = empty
+pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |"))
(map (pprIfaceConDecl tc) cs))
pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
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 is_infix then ptext (sLit "Infix") else empty,
if null strs then empty
- else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
+ 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))]
+ else 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
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],
+ ptext (sLit "forall") <+> pprIfaceBndrs bndrs],
nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
- ptext SLIT("=") <+> ppr rhs])
+ 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
+ = hang (ptext (sLit "instance") <+> ppr flag
<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr dfun_id)
instance Outputable IfaceFamInst where
ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
ifFamInstTyCon = tycon_id})
- = hang (ptext SLIT("family instance") <+>
+ = hang (ptext (sLit "family instance") <+>
ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
2 (equals <+> ppr tycon_id)
-- 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 (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
-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 e = (reverse bs, e)
pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
- = 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 '}'])
pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
- = 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 add_par (IfaceCast expr co)
+pprIfaceExpr _ (IfaceCast expr co)
= sep [pprIfaceExpr parens expr,
- nest 2 (ptext SLIT("`cast`")),
+ 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)
+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 :: (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 :: IfaceExpr -> [SDoc] -> SDoc
pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
pprIfaceApp fun args = sep (pprIfaceExpr parens fun : args)
------------------
instance Outputable IfaceNote where
ppr (IfaceSCC cc) = pprCostCentreCore cc
- ppr IfaceInlineMe = ptext SLIT("__inline_me")
- ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
+ ppr IfaceInlineMe = ptext (sLit "__inline_me")
+ 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 is) <+> ptext SLIT("-}")
+ ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}")
instance Outputable IfaceInfoItem where
- ppr (HsUnfold unf) = ptext SLIT("Unfolding:") <+>
+ ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+>
parens (pprIfaceExpr noParens unf)
- ppr (HsInline act) = ptext SLIT("Inline:") <+> ppr act
- ppr (HsArity arity) = ptext SLIT("Arity:") <+> int arity
- ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
- ppr HsNoCafRefs = ptext SLIT("HasNoCafRefs")
- ppr (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a
-\end{code}
-
-
-%************************************************************************
-%* *
- Equality, for interface file version generaion only
-%* *
-%************************************************************************
+ ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act
+ ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity
+ ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str
+ ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs")
+ ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a
-Equality over IfaceSyn returns an IfaceEq, not a Bool. The new
-constructor is EqBut, which gives the set of things whose version must
-be equal for the whole thing to be equal. So the key function is
-eqIfExt, which compares Names.
-Of course, equality is also done modulo alpha conversion.
+-- -----------------------------------------------------------------------------
+-- 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 i) =
+ freeNamesIfType t &&&
+ freeNamesIfIdInfo i
+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)
-\begin{code}
-data GenIfaceEq a
- = Equal -- Definitely exactly the same
- | NotEqual -- Definitely different
- | EqBut a -- The same provided these Names have not changed
-
-type IfaceEq = GenIfaceEq NameSet
-
-instance Outputable IfaceEq where
- ppr Equal = ptext SLIT("Equal")
- ppr NotEqual = ptext SLIT("NotEqual")
- ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
-
-bool :: Bool -> IfaceEq
-bool True = Equal
-bool False = NotEqual
-
-toBool :: IfaceEq -> Bool
-toBool Equal = True
-toBool (EqBut _) = True
-toBool NotEqual = False
-
-zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information
-zapEq (EqBut _) = Equal
-zapEq other = other
-
-(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
-Equal &&& x = x
-NotEqual &&& x = NotEqual
-EqBut nms &&& Equal = EqBut nms
-EqBut nms &&& NotEqual = NotEqual
-EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
-
--- This function is the core of the EqBut stuff
--- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
--- any Names in the left-hand arg have the correct parent in them.
-eqIfExt :: Name -> Name -> IfaceEq
-eqIfExt name1 name2
- | name1 == name2 = EqBut (unitNameSet name1)
- | otherwise = NotEqual
-
----------------------
-checkBootDecl :: IfaceDecl -- The boot decl
- -> IfaceDecl -- The real decl
- -> Bool -- True <=> compatible
-checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
- = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)
-
-checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
- = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2
-
-checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
- = ASSERT( ifName d1 == ifName d2 )
- toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
- eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
-
-checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
--- We don't check the recursion flags because the boot-one is
--- recursive, to be conservative, but the real one may not be.
--- I'm not happy with the way recursive flags are dealt with.
- = ASSERT( ifName d1 == ifName d2 )
- toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- case ifCons d1 of
- IfAbstractTyCon -> Equal
- cons1 -> eq_hsCD env cons1 (ifCons d2)
-
-checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
- = ASSERT( ifName d1 == ifName d2 )
- toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env ->
- eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
- case (ifCtxt d1, ifSigs d1) of
- ([], []) -> Equal
- (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&&
- eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)
-
-checkBootDecl _ _ = False -- default case
-
----------------------
-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 &&
- ifGadtSyntax d1 == ifGadtSyntax d2 &&
- ifGeneric d1 == ifGeneric d2) &&&
- ifFamInst d1 `eqIfTc_fam` ifFamInst 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) &&&
- ifFamInst d1 `eqIfTc_fam` ifFamInst 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) &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
- eqListBy eqIfDecl (ifATs d1) (ifATs 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
-
-eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType])
- -> Maybe (IfaceTyCon, [IfaceType])
- -> IfaceEq
-Nothing `eqIfTc_fam` Nothing = Equal
-(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) =
- fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
-_ `eqIfTc_fam` _ = NotEqual
-
-
------------------------
-eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
--- All other changes are handled via the version info on the dfun
-
-eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
-- All other changes are handled via the version info on the tycon
-
-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 IfOpenDataTyCon IfOpenDataTyCon = Equal
-eq_hsCD env d1 d2 = NotEqual
-
-eq_ConDecl env c1 c2
- = bool (ifConOcc c1 == ifConOcc c2 &&
- ifConInfix c1 == ifConInfix c2 &&
- ifConStricts c1 == ifConStricts c2 &&
- ifConFields c1 == ifConFields c2) &&&
- eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
- eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
- eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
- eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
-
-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 (HsInline a1) (HsInline a2) = bool (a1 == a2)
-eq_item (HsArity a1) (HsArity a2) = bool (a1 == a2)
-eq_item (HsStrictness s1) (HsStrictness s2) = bool (s1 == s2)
-eq_item (HsUnfold u1) (HsUnfold u2) = 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 (IfaceTick m1 ix1) (IfaceTick m2 ix2) = bool (m1==m2) &&& bool (ix1 == ix2)
-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 (IfaceCast e1 co1) (IfaceCast e2 co2) = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
-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)
+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
+
+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) = freeNamesIfExpr u
+freeNamesItem (HsWorker wkr _) = unitNameSet wkr
+freeNamesItem _ = emptyNameSet
+
+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 _ body) = 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 &&& freeNamesIfType ty &&& fnList freeNamesIfaceAlt alts
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)
+ -- no need to look at the constructor, because we'll already have its
+ -- parent recorded by the type on the case expression.
+ freeNamesIfaceAlt (_con,_bs,r) = freeNamesIfExpr r
-eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
- = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
+freeNamesIfExpr (IfaceLet (IfaceNonRec _bndr r) x)
+ = freeNamesIfExpr r &&& freeNamesIfExpr x
-eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
- = eq_ifLetBndrs 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 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 IfaceLiftedTypeKindTc IfaceLiftedTypeKindTc = Equal
-eqIfTc IfaceOpenTypeKindTc IfaceOpenTypeKindTc = Equal
-eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
-eqIfTc IfaceUbxTupleKindTc IfaceUbxTupleKindTc = Equal
-eqIfTc IfaceArgTypeKindTc IfaceArgTypeKindTc = Equal
-eqIfTc _ _ = NotEqual
-\end{code}
-
------------------------------------------------------------
- Support code for equality checking
------------------------------------------------------------
-
-\begin{code}
-------------------------------------
-type EqEnv = UniqFM FastString -- Tracks the mapping from L-variables to R-variables
+freeNamesIfExpr (IfaceLet (IfaceRec as) x)
+ = fnList freeNamesIfExpr (map snd as) &&& freeNamesIfExpr x
-eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
-eqIfOcc env n1 n2 = case lookupUFM env n1 of
- Just n1 -> bool (n1 == n2)
- Nothing -> bool (n1 == n2)
+freeNamesIfExpr _ = emptyNameSet
-extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
-extendEqEnv env n1 n2 | n1 == n2 = env
- | otherwise = addToUFM env n1 n2
-emptyEqEnv :: EqEnv
-emptyEqEnv = emptyUFM
+freeNamesIfTc :: IfaceTyCon -> NameSet
+freeNamesIfTc (IfaceTc tc) = unitNameSet tc
+-- ToDo: shouldn't we include IfaceIntTc & co.?
+freeNamesIfTc _ = emptyNameSet
-------------------------------------
-type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq
+freeNamesIfRule :: IfaceRule -> NameSet
+freeNamesIfRule (IfaceRule _n _a bs f es rhs _o)
+ = unitNameSet f &&&
+ fnList freeNamesIfBndr bs &&&
+ fnList freeNamesIfExpr es &&&
+ freeNamesIfExpr rhs
-eq_ifNakedBndr :: ExtEnv FastString
-eq_ifBndr :: ExtEnv IfaceBndr
-eq_ifTvBndr :: ExtEnv IfaceTvBndr
-eq_ifIdBndr :: ExtEnv IfaceIdBndr
+-- helpers
+(&&&) :: NameSet -> NameSet -> NameSet
+(&&&) = unionNameSets
-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 = eq_ifType env 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_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k
- = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)
-
-eq_ifBndrs :: ExtEnv [IfaceBndr]
-eq_ifLetBndrs :: ExtEnv [IfaceLetBndr]
-eq_ifTvBndrs :: ExtEnv [IfaceTvBndr]
-eq_ifNakedBndrs :: ExtEnv [FastString]
-eq_ifBndrs = eq_bndrs_with eq_ifBndr
-eq_ifTvBndrs = eq_bndrs_with eq_ifTvBndr
-eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
-eq_ifLetBndrs = eq_bndrs_with eq_ifLetBndr
-
-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}
-
-\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}
projects / ghc-hetmet.git / blobdiff