X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=49fded9a59becb86e5ee89158c0020dfaac912d1;hp=99501a5b68f0f385de6c4f930908f8f0dfe52c7c;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 99501a5..49fded9 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -1,340 +1,570 @@ % +% (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 + module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), - IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), - IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), - -- Misc - visibleIfConDecls, + -- Misc + 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 + -- Pretty printing + 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 CoreSyn( DFunArg, dfunArgExprs ) +import PprCore() -- Printing DFunArgs +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} %************************************************************************ -%* * - 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? - 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 +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: + -- 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 - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive? - ifVrcs :: ArgVrcs -- ... and what are its argument variances ... + | 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 } + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move + -- beyond .NET + 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 - | 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 = [] +visibleIfConDecls IfOpenDataTyCon = [] visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] -data IfaceConDecl - = IfVanillaCon { - ifConOcc :: OccName, -- Constructor name - 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 - 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 - -data IfaceInst - = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: OccName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance - -- 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 IfaceConDecl + = IfCon { + 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 :: 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 :: IfaceExtName, -- 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 - | 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 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 OccName - | IfaceExt IfaceExtName + = 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 OccName IfaceType [IfaceAlt] + | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType + | 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) - -- 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 OccName - | IfaceTupleAlt Boxity - | IfaceLitAlt Literal + | IfaceDataAlt IfExtName + | 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 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). -%************************************************************************ -%* * -\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. + +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 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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}) - = sep [ ppr var <+> dcolon <+> ppr ty, - nest 2 (ppr 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] - -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 (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, - ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifVrcs = vrcs}) + = 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 = Nothing, ifSynKind = kind }) + = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) + 4 (dcolon <+> ppr kind) + +pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, + ifTyVars = tyvars, ifCons = condecls, + 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, pp_condecls tycon condecls, + pprFamily mbFamInst]) where pp_nd = case condecls of - IfAbstractTyCon -> ptext SLIT("data") - 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)]) - -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") + 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)]) + +pprRec :: RecFlag -> SDoc +pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec + +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_bang strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + where + ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang bang = ppr bang + + 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 }) + 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)) + 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) - 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} @@ -344,655 +574,341 @@ instance Outputable IfaceInst where 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 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 _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co 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 _ _) +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) --- 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") +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 '}']) --- 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") +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 [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]) + = add_par (sep [ptext (sLit "letrec {"), + 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 (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 -> [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_bind ((b,ty),rhs) = sep [ppr b <+> dcolon <+> ppr ty, - equals <+> pprIfaceExpr noParens rhs] +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 (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} - - -%************************************************************************ -%* * - Converting things to their Iface equivalents -%* * -%************************************************************************ +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) - -\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 "") <+> 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 + +-- 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 +freeNamesIfType (IfaceCoConApp tc ts) = + freeNamesIfCo tc &&& fnList freeNamesIfType ts + +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 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 + +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 (IfExtWrapper _ v) = unitNameSet v +freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) + +freeNamesIfExpr :: IfaceExpr -> NameSet +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 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 _ alts) + = freeNamesIfExpr s + &&& fnList fn_alt alts &&& fn_cons alts where - name = idName v -\end{code} + fn_alt (_con,_bs,r) = freeNamesIfExpr r + -- 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 -%************************************************************************ -%* * - Equality, for interface file version generaion only -%* * -%************************************************************************ +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body -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. +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs -Of course, equality is also done modulo alpha conversion. +freeNamesIfExpr _ = emptyNameSet -\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} +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 -\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} +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSets -\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) - 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) - -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) - -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 +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f \end{code} ------------------------------------------------------------ - Support code for equality checking ------------------------------------------------------------ +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. -\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} - -\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 -\end{code}