X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=49fded9a59becb86e5ee89158c0020dfaac912d1;hp=39a1fd2fd61aff7b953b84bf28408526939f8870;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 39a1fd2..49fded9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -5,115 +5,110 @@ \begin{code} module IfaceSyn ( - module IfaceType, -- Re-export all this + module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), - IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), - -- Misc + -- Misc ifaceDeclSubBndrs, visibleIfConDecls, -- Free Names freeNamesIfDecl, freeNamesIfRule, - -- Pretty printing - pprIfaceExpr, pprIfaceDeclHead + -- Pretty printing + pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" import IfaceType - -import NewDemand +import CoreSyn( DFunArg, dfunArgExprs ) +import PprCore() -- Printing DFunArgs +import Demand +import Annotations import Class -import NameSet +import NameSet import Name import CostCentre import Literal import ForeignCall +import Serialized import BasicTypes import Outputable import FastString import Module -import Data.List -import Data.Maybe - infixl 3 &&& \end{code} %************************************************************************ -%* * - Data type declarations -%* * +%* * + Data type declarations +%* * %************************************************************************ \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? - 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 +data IfaceDecl + = 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 ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family - -- Invariant: + -- Invariant: -- ifCons /= IfOpenDataTyCon -- for family instances } - | 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]) + | 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 FastString], -- Functional dependencies - ifATs :: [IfaceDecl], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceDecl], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? } | IfaceForeign { ifName :: OccName, -- Needs expanding when we move -- beyond .NET - ifExtName :: Maybe FastString } + ifExtName :: Maybe FastString } -data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType - -- Nothing => no default method - -- Just False => ordinary polymorphic default method - -- Just True => generic default method +data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method data IfaceConDecls - = IfAbstractTyCon -- No info - | IfOpenDataTyCon -- Open data family - | IfDataTyCon [IfaceConDecl] -- data type decls - | IfNewTyCon IfaceConDecl -- newtype decls + = IfAbstractTyCon -- No info + | IfOpenDataTyCon -- Open data family + | IfDataTyCon [IfaceConDecl] -- data type decls + | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] @@ -121,116 +116,159 @@ visibleIfConDecls IfOpenDataTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] -data IfaceConDecl +data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name - ifConInfix :: Bool, -- True <=> declared infix - ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars - ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints - ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [StrictnessMark]} -- Empty (meaning all lazy), - -- or 1-1 corresp with arg tys - -data IfaceInst - = IfaceInst { ifInstCls :: Name, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: Name, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - 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, - -- and we don't want that to wobble gratuitously - -- 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 + ifConOcc :: OccName, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars + ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [OccName], -- ...ditto... (field labels) + ifConStricts :: [HsBang]} -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + +data IfaceInst + = IfaceInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + 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, + -- and we don't want that to wobble gratuitously + -- 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 - } + = IfaceFamInst { ifFamInstFam :: IfExtName -- 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 :: Name, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr, - ifRuleOrph :: Maybe OccName -- Just like IfaceInst + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + 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 Int -- Number of silent args + data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O -- * When we read in old A.hi we read in its IdInfo (as a thunk) --- (In earlier GHCs we used to drop IdInfo immediately on reading, --- but we do not do that now. Instead it's discarded when the --- ModIface is read into the various decl pools.) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *) --- and so gives a new version. +-- and so gives a new version. data IfaceInfoItem - = HsArity Arity + = HsArity Arity | HsStrictness StrictSig - | HsInline Activation - | HsUnfold IfaceExpr + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs - | HsWorker Name 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 Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding + -- Possibly could eliminate the Bool here, the information + -- is also in the InlinePragma. + + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + + | IfInlineRule Arity -- INLINE pragmas + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) + | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in + -- another module. + + | IfDFunUnfold [DFunArg IfaceExpr] + -------------------------------- data IfaceExpr - = IfaceLcl FastString - | IfaceExt Name + = IfaceLcl IfLclName + | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr FastString IfaceType [IfaceAlt] + | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre - | IfaceInlineMe | IfaceCoreNote String -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 +type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) + -- Note: IfLclName, 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 Name - | IfaceTupleAlt Boxity - | IfaceLitAlt Literal + | IfaceDataAlt IfExtName + | IfaceTupleAlt Boxity + | IfaceLitAlt Literal data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, 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 +data IfaceLetBndr = IfLetBndr IfLclName 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). + Note [IdInfo on nested let-bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Occasionally we want to preserve IdInfo on nested let bindings. The one @@ -238,10 +276,8 @@ 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. - +In general we retain all info that is left by CoreTidy.tidyLetBndr, since +that is what is seen by importing module with --make Note [Orphans]: the ifInstOrph and ifRuleOrph fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -257,9 +293,9 @@ complicate the situation though. Consider and suppose we are compiling module X: module X where - import M - data T = ... - instance C Int T 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 @@ -273,7 +309,7 @@ More precisely, an instance is an orphan iff 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. + defined in this module. (Note that these conditions hold trivially if the class is locally defined.) @@ -300,10 +336,10 @@ a functionally-dependent part of the instance decl. E.g. and suppose we are compiling module X: module X where - import M - data S = ... - data T = ... - instance C S T 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 @@ -314,8 +350,8 @@ 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. +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. \begin{code} @@ -337,48 +373,39 @@ ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} = [] -- Newtype ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ, - ifConFields = fields - }), - ifFamInst = famInst}) - = -- fields (names of selectors) - fields ++ - -- implicit coerion and (possibly) family instance coercion + 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) + -- 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}) - = -- 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 + 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 - 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 (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) + | 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 : + tc_occ : -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) @@ -395,14 +422,14 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, n_ctxt = length sc_ctxt n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ co_occs | is_newtype = [mkNewTyCoOcc tc_occ] - | otherwise = [] + | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh + is_newtype = n_sigs + n_ctxt == 1 -- Sigh ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, - ifFamInst = famInst}) + ifFamInst = famInst}) = famInstCo famInst tc_occ ifaceDeclSubBndrs _ = [] @@ -418,52 +445,50 @@ 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 (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] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifOpenSyn = False, ifSynRhs = mono_ty, +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, - ifOpenSyn = True, ifSynRhs = mono_ty}) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Nothing, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) - 4 (dcolon <+> ppr mono_ty) + 4 (dcolon <+> ppr kind) -pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, - ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifFamInst = mbFamInst}) +pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifFamInst = mbFamInst}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls, - pprFamily mbFamInst]) + 4 (vcat [pprRec isrec, pp_condecls tycon 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") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) + 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) 4 (vcat [pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) + sep (map ppr ats), + sep (map ppr sigs)]) 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 @@ -473,64 +498,68 @@ instance Outputable IfaceClassOp where pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), + pprIfaceTvBndrs tyvars] pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}") pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls _ IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) - (map (pprIfaceConDecl tc) cs)) + (map (pprIfaceConDecl tc) cs)) pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, - ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) + (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 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))] + 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_bang 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 + ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang bang = ppr bang - eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + main_payload = ppr name <+> dcolon <+> + pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - -- 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 + 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" + (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 }) + 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_rough mb_tcs)) + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = 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") <+> - ppr fam <+> brackets (pprWithCommas ppr_rough 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 @@ -545,9 +574,14 @@ ppr_rough (Just tc) = ppr tc instance Outputable IfaceExpr where ppr e = pprIfaceExpr noParens e +pprParendIfaceExpr :: IfaceExpr -> SDoc +pprParendIfaceExpr = pprIfaceExpr parens + +-- | Pretty Print an IfaceExpre +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) pprIfaceExpr _ (IfaceLcl v) = ppr v pprIfaceExpr _ (IfaceExt v) = ppr v @@ -555,98 +589,121 @@ 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 _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) -pprIfaceExpr add_par e@(IfaceLam _ _) +pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow, - pprIfaceExpr noParens body]) - where - (bndrs,body) = collect [] e + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i collect bs (IfaceLam b e) = collect (b:bs) e 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 add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [ptext (sLit "case") <+> 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 add_par (IfaceCase scrut bndr alts) + = add_par (sep [ptext (sLit "case") <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) - = sep [pprIfaceExpr parens expr, - nest 2 (ptext (sLit "`cast`")), - pprParendIfaceType 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 {"), - nest 2 (ppr_bind (b, rhs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + = add_par (sep [ptext (sLit "let {"), + nest 2 (ppr_bind (b, rhs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) = add_par (sep [ptext (sLit "letrec {"), - nest 2 (sep (map ppr_bind pairs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + nest 2 (sep (map ppr_bind pairs)), + 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_alt :: (IfaceConAlt, [IfLclName], 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 :: IfaceConAlt -> [IfLclName] -> 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_con_bs con bs = ppr con <+> hsep (map ppr bs) + ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc -ppr_bind (IfLetBndr b ty info, rhs) +ppr_bind (IfLetBndr b ty info, rhs) = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), - equals <+> pprIfaceExpr noParens rhs] + 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) +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 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 (IfaceLitAlt l) = ppr l ppr (IfaceDataAlt d) = ppr d - ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" + ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" -- IfaceTupleAlt is handled by the case-alternative printer ------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = empty + ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc + <+> if b then ptext (sLit "") else empty + ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) + instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> fsep (map ppr is) <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is + <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold unf) = ptext (sLit "Unfolding:") <+> - parens (pprIfaceExpr noParens unf) - ppr (HsInline act) = ptext (sLit "Inline:") <+> ppr act + 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") - ppr (HsWorker w a) = ptext (sLit "Worker:") <+> ppr w <+> int a - + ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") + +instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) + ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr + <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr + <+> parens (ptext (sLit "arity") <+> int a) + ppr (IfDFunUnfold ns) = ptext (sLit "DFun:") + <+> brackets (pprWithCommas ppr ns) -- ----------------------------------------------------------------------------- --- Finding the Names in IfaceSyn +-- | 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 @@ -656,10 +713,11 @@ instance Outputable IfaceInfoItem where -- fingerprinting the instance, so DFuns are not dependencies. freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t i) = +freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfType t &&& - freeNamesIfIdInfo i -freeNamesIfDecl IfaceForeign{} = + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d +freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& @@ -668,7 +726,7 @@ freeNamesIfDecl d@IfaceData{} = freeNamesIfConDecls (ifCons d) freeNamesIfDecl d@IfaceSyn{} = freeNamesIfTvBndrs (ifTyVars d) &&& - freeNamesIfType (ifSynRhs d) &&& + freeNamesIfSynRhs (ifSynRhs d) &&& freeNamesIfTcFam (ifFamInst d) freeNamesIfDecl d@IfaceClass{} = freeNamesIfTvBndrs (ifTyVars d) &&& @@ -676,9 +734,17 @@ freeNamesIfDecl d@IfaceClass{} = 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)) = +freeNamesIfTcFam (Just (tc,tys)) = freeNamesIfTc tc &&& fnList freeNamesIfType tys freeNamesIfTcFam Nothing = emptyNameSet @@ -698,15 +764,15 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl c = +freeNamesIfConDecl c = freeNamesIfTvBndrs (ifConUnivTvs c) &&& freeNamesIfTvBndrs (ifConExTvs c) &&& - freeNamesIfContext (ifConCtxt c) &&& + freeNamesIfContext (ifConCtxt c) &&& fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints freeNamesIfPredType :: IfacePredType -> NameSet -freeNamesIfPredType (IfaceClassP cl tys) = +freeNamesIfPredType (IfaceClassP cl tys) = unitNameSet cl &&& fnList freeNamesIfType tys freeNamesIfPredType (IfaceIParam _n ty) = freeNamesIfType ty @@ -717,11 +783,13 @@ freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st -freeNamesIfType (IfaceTyConApp tc ts) = +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 +freeNamesIfType (IfaceCoConApp tc ts) = + freeNamesIfCo tc &&& fnList freeNamesIfType ts freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet freeNamesIfTvBndrs = fnList freeNamesIfTvBndr @@ -730,6 +798,13 @@ 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 IdInfo can contain an unfolding (in the case of +-- local INLINE pragmas), so look there too +freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty + &&& freeNamesIfIdInfo info + freeNamesIfTvBndr :: IfaceTvBndr -> NameSet freeNamesIfTvBndr (_fs,k) = freeNamesIfType k -- kinds can have Names inside, when the Kind is an equality predicate @@ -738,47 +813,67 @@ freeNamesIfIdBndr :: IfaceIdBndr -> NameSet freeNamesIfIdBndr = freeNamesIfTvBndr freeNamesIfIdInfo :: IfaceIdInfo -> NameSet -freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet -freeNamesItem (HsUnfold u) = freeNamesIfExpr u -freeNamesItem (HsWorker wkr _) = unitNameSet wkr -freeNamesItem _ = emptyNameSet +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 (IfExtWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) freeNamesIfExpr :: IfaceExpr -> NameSet -freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfType co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as -freeNamesIfExpr (IfaceLam _ body) = freeNamesIfExpr body +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 (IfaceNote _n r) = freeNamesIfExpr r -freeNamesIfExpr (IfaceCase s _ ty alts) - = freeNamesIfExpr s &&& freeNamesIfType ty &&& fnList freeNamesIfaceAlt alts +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s + &&& fnList fn_alt alts &&& fn_cons alts where - -- 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 + fn_alt (_con,_bs,r) = freeNamesIfExpr r -freeNamesIfExpr (IfaceLet (IfaceNonRec _bndr r) x) - = freeNamesIfExpr r &&& freeNamesIfExpr x + -- Depend on the data constructors. Just one will do! + -- Note [Tracking data constructors] + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet + +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body freeNamesIfExpr (IfaceLet (IfaceRec as) x) - = fnList freeNamesIfExpr (map snd as) &&& freeNamesIfExpr x + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs freeNamesIfExpr _ = emptyNameSet - freeNamesIfTc :: IfaceTyCon -> NameSet freeNamesIfTc (IfaceTc tc) = unitNameSet tc -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfTc _ = emptyNameSet +freeNamesIfCo :: IfaceCoCon -> NameSet +freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc +freeNamesIfCo _ = emptyNameSet + freeNamesIfRule :: IfaceRule -> NameSet -freeNamesIfRule (IfaceRule _n _a bs f es rhs _o) +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) = unitNameSet f &&& fnList freeNamesIfBndr bs &&& fnList freeNamesIfExpr es &&& @@ -791,3 +886,29 @@ freeNamesIfRule (IfaceRule _n _a bs f es rhs _o) 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. +