X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fiface%2FIfaceSyn.lhs;h=a15f224c8c959a68ad4d025d647965351321d6f4;hb=f908524d82242e634347857726651be08f3e9f5d;hp=6ad7b0794f4b53e1c3c022a95cc3b174e0d8c785;hpb=9694f168f43d39c92a47d10564f620c657addb12;p=ghc-hetmet.git diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 6ad7b07..a15f224 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -14,20 +14,23 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module IfaceSyn ( module IfaceType, -- Re-export all this - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), + -- Misc + visibleIfConDecls, + -- Converting things to IfaceSyn - tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule, + tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule, -- Equality IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, eqIfDecl, eqIfInst, eqIfRule, -- Pretty printing - pprIfaceExpr, pprIfaceDecl + pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead ) where #include "HsVersions.h" @@ -37,33 +40,33 @@ import IfaceType import FunDeps ( pprFundeps ) import NewDemand ( StrictSig, pprIfaceStrictSig ) -import TcType ( deNoteType, mkSigmaTy, tcSplitDFunTy, mkClassPred ) -import Type ( TyThing(..), mkForAllTys, mkFunTys, splitForAllTys, funResultTy, - mkTyVarTys, mkTyConApp, mkTyVarTys, mkPredTy, tidyTopType ) -import InstEnv ( DFunId ) +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 ( ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon, - isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, - isTupleTyCon, tupleTyConBoxity, - tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, - tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName ) +import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, + isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, + isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, + tyConHasGenerics, tyConArgVrcs, getSynTyConDefn, + tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, - dataConTyCon ) + dataConTyCon, dataConIsInfix, isVanillaDataCon ) import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) -import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv, - lookupOccEnv, extendOccEnv, emptyOccEnv, +import OccName ( OccName, OccEnv, emptyOccEnv, + lookupOccEnv, extendOccEnv, parenSymOcc, OccSet, unionOccSets, unitOccSet ) -import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName ) -import Module ( ModuleName ) +import Name ( Name, NamedThing(..), nameOccName, isExternalName, + wiredInNameTyThing_maybe ) +import NameSet ( NameSet, elemNameSet ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) import TysPrim ( alphaTyVars ) -import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..), +import BasicTypes ( Arity, Activation(..), StrictnessMark, RecFlag(..), boolToRecFlag, Boxity(..), tupleParens ) import Outputable @@ -88,11 +91,10 @@ data IfaceDecl ifType :: IfaceType, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifND :: NewOrData, - ifCtxt :: IfaceContext, -- Context - ifName :: OccName, -- Type constructor + | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables - ifCons :: DataConDetails IfaceConDecl, + 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 @@ -106,16 +108,16 @@ data IfaceDecl ifSynRhs :: IfaceType -- synonym expansion } - | 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 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 ... } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType @@ -123,17 +125,37 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType -- 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 + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + data IfaceConDecl - = IfaceConDecl OccName -- Constructor name - [IfaceTvBndr] -- Existental tyvars - IfaceContext -- Existential context - [IfaceType] -- Arg types - [StrictnessMark] -- Empty (meaning all lazy), or 1-1 corresp with arg types - [OccName] -- ...ditto... (field labels) + = 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 { ifInstHead :: IfaceType, -- Just the instance head type, quantified - -- so that it'll compare alpha-wise - ifDFun :: OccName } -- And the dfun +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, @@ -145,43 +167,36 @@ 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 + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst } - | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can - -- wait in the RulePol data IfaceIdInfo = NoInfo -- When writing interface file without -O | HasInfo [IfaceInfoItem] -- Has info, and here it is - | DiscardedInfo -- HasInfo in the .hi file, but discarded - -- when it was read in --- Here's why we need this NoInfo/DiscardedInfo stuff + +-- 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 --- * If we read in A.hi and discard IdInfo, the --- new (empty) IdInfo for f looks like the --- old (discarded) IdInfo for f --- => no new version # for f --- * But that might mean that we fail to recompile B, when --- actually we should --- --- * We also want to ensure that if A.hi was *already* compiled --- without -O we *don't* then recompile B --- --- When we discard IdInfo on *reading* we make it into DiscardedInfo --- On *writing* we make it NoInfo --- DiscardedInfo is never written into a file +-- * 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.) +-- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. data IfaceInfoItem = HsArity Arity | HsStrictness StrictSig | HsUnfold Activation IfaceExpr | HsNoCafRefs - | HsWorker OccName Arity -- Worker, if any see IdInfo.WorkerInfo - -- for why we want arity here. + | 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. @@ -193,7 +208,7 @@ data IfaceExpr | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr OccName [IfaceAlt] + | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceLit Literal @@ -241,18 +256,24 @@ 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") <+> pp_decl_head [] tycon tyvars) + = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) -pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon, ifGeneric = gen, - ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) - = hang (ppr new_or_data <+> pp_decl_head context tycon tyvars) - 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls]) +pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifVrcs = vrcs}) + = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) + 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) + 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") <+> pp_decl_head context clas tyvars <+> pprFundeps fds) + = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprVrcs vrcs, pprRec isrec, sep (map ppr sigs)]) @@ -265,36 +286,57 @@ pprGen False = ptext SLIT("Generics: no") instance Outputable IfaceClassOp where ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty -pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc -pp_decl_head context thing tyvars - = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] - -pp_condecls Unknown = ptext SLIT("{- abstract -}") -pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) - -instance Outputable IfaceConDecl where - ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields) - = pprIfaceForAllPart ex_tvs ex_ctxt $ - sep [ppr name <+> sep (map pprParendIfaceType arg_tys), +pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc +pprIfaceDeclHead context thing tyvars + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars] + +pp_condecls tc 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 + instance Outputable IfaceRule where - ppr (IfaceRule name act bndrs fn args rhs) + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, ptext SLIT("forall") <+> pprIfaceBndrs bndrs], nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args), ptext SLIT("=") <+> ppr rhs]) ] - ppr (IfaceBuiltinRule name rule) - = ptext SLIT("Built-in rule for") <+> ppr name instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty}) - = hang (ptext SLIT("instance") <+> ppr ty) + 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)) 2 (equals <+> ppr dfun_id) + where + ppr_mb Nothing = dot + ppr_mb (Just tc) = ppr tc \end{code} @@ -325,13 +367,17 @@ pprIfaceExpr add_par e@(IfaceLam _ _) collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- 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") <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr alts) - = add_par (sep [ptext SLIT("case") <+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") +-- 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") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) @@ -371,16 +417,16 @@ instance Outputable IfaceNote where 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 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 ------------------ instance Outputable IfaceIdInfo where - ppr NoInfo = empty - ppr DiscardedInfo = ptext SLIT("") - ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr_hs_info is) <+> ptext SLIT("-}") + 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)] @@ -399,16 +445,21 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a \begin{code} -tyThingToIfaceDecl :: Bool -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl -tyThingToIfaceDecl discard_prags ext (AnId id) +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 | discard_prags = NoInfo - | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id)) + info = case toIfaceIdInfo ext (idInfo id) of + [] -> NoInfo + items -> HasInfo items -tyThingToIfaceDecl _ ext (AClass clas) +tyThingToIfaceDecl ext (AClass clas) = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, @@ -434,7 +485,7 @@ tyThingToIfaceDecl _ ext (AClass clas) toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) -tyThingToIfaceDecl _ ext (ATyCon tycon) +tyThingToIfaceDecl ext (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, @@ -442,11 +493,10 @@ tyThingToIfaceDecl _ ext (ATyCon tycon) ifSynRhs = toIfaceType ext syn_ty } | isAlgTyCon tycon - = IfaceData { ifND = new_or_data, - ifCtxt = toIfaceContext ext (tyConTheta tycon), - ifName = getOccName tycon, + = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifCons = ifaceConDecls (tyConDataConDetails tycon), + ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifVrcs = tyConArgVrcs tycon, ifGeneric = tyConHasGenerics tycon } @@ -457,74 +507,66 @@ tyThingToIfaceDecl _ ext (ATyCon tycon) | isPrimTyCon tycon || isFunTyCon tycon -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifND = DataType, - ifCtxt = [], - ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCons = Unknown, - ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } + = 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) = getSynTyConDefn tycon - new_or_data | isNewTyCon tycon = NewType - | otherwise = DataType - ifaceConDecls Unknown = Unknown - ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) + ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon 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 - = IfaceConDecl (getOccName (dataConName data_con)) - (toIfaceTvBndrs ex_tyvars) - (toIfaceContext ext ex_theta) - (map (toIfaceType ext) arg_tys) - strict_marks - (map getOccName field_labels) + | 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 - (_, _, ex_tyvars, ex_theta, arg_tys, _) = dataConSig data_con + (tyvars, theta, arg_tys, _, res_tys) = dataConSig data_con field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con - -- This case only happens in the call to ifaceThing in InteractiveUI - -- Otherwise DataCons are filtered out in ifaceThing_acc -tyThingToIfaceDecl _ ext (ADataCon dc) - = IfaceId { ifName = getOccName dc, - ifType = toIfaceType ext full_ty, - ifIdInfo = NoInfo } - where - (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig dc - - -- The "stupid context" isn't part of the wrapper-Id type - -- (for better or worse -- see note in DataCon.lhs), so we - -- have to make it up here - full_ty = mkSigmaTy (tvs ++ ex_tvs) (stupid_theta ++ ex_theta) - (mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tvs))) +tyThingToIfaceDecl ext (ADataCon dc) + = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier + -------------------------- -dfunToIfaceInst :: ModuleName -> DFunId -> IfaceInst -dfunToIfaceInst mod dfun_id - = IfaceInst { ifDFun = getOccName dfun_id, - ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty } +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 - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id) - head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys)) - -- No need to record the instance context; - -- it's in the dfun anyway - - tidy_ty = tidyTopType (deNoteType head_ty) - -- The deNoteType is very important. It removes all type - -- synonyms from the instance type in interface files. - -- That in turn makes sure that when reading in instance decls - -- from interface files that the 'gating' mechanism works properly. - -- Otherwise you could have - -- type Tibble = T Int - -- instance Foo Tibble where ... - -- and this instance decl wouldn't get imported into a module - -- that mentioned T but not Tibble. - + do_rough Nothing = Nothing + do_rough (Just n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n + = Just (toIfaceTyCon ext_lhs tc) + | otherwise + = Just (IfaceTc (ext_lhs n)) -------------------------- toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] @@ -554,7 +596,7 @@ toIfaceIdInfo ext 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 (getOccName work_id) wrap_arity) + Just (HsWorker (ext (idName work_id)) wrap_arity) NoWorker -> Nothing ------------ Unfolding -------------- @@ -567,21 +609,35 @@ toIfaceIdInfo ext id_info | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) -------------------------- -coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule -coreRuleToIfaceRule mod ext (id, BuiltinRule _ _) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id))) - -coreRuleToIfaceRule mod ext (id, Rule name act bndrs args rhs) - = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map (toIfaceBndr ext) bndrs, - ifRuleHead = ext (getName id), - ifRuleArgs = map (toIfaceExpr (mkLhsNameFn mod)) args, - -- Use LHS name-fn for the args - ifRuleRhs = 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 FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name) + = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } --------------------- toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr @@ -590,7 +646,8 @@ 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] -toIfaceExpr ext (Case s x as) = IfaceCase (toIfaceExpr ext s) (getOccName x) (map (toIfaceAlt ext) as) +-- 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) @@ -645,18 +702,6 @@ toIfaceVar ext v | otherwise = IfaceLcl (nameOccName name) where name = idName v - ---------------------- --- mkLhsNameFn ignores versioning info altogether --- Used for the LHS of instance decls and rules, where we --- there's no point in recording version info -mkLhsNameFn :: ModuleName -> Name -> IfaceExtName -mkLhsNameFn this_mod name - | mod == this_mod = LocalTop occ - | otherwise = ExtPkg mod occ - where - mod = nameModuleName name - occ = nameOccName name \end{code} @@ -717,14 +762,16 @@ eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) = bool (ifName d1 == ifName d2 && - ifND d1 == ifND 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) + 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) &&& @@ -749,30 +796,41 @@ eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq eqWith = eq_ifTvBndrs emptyEqEnv ----------------------- -eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&& - zapEq (ifInstHead d1 `eqIfType` ifInstHead d2) - -- zapEq: for instances, ignore the EqBut part +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) - (IfaceRule n2 a2 bs2 f2 es2 rhs2) - = bool (n1==n2 && a1==a2) &&& +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) -eqIfRule _ _ = NotEqual -eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2 -eq_hsCD env Unknown Unknown = Equal -eq_hsCD env d1 d2 = NotEqual +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 (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1) - (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2) - = bool (n1 == n2 && ss1 == ss2 && lbls1 == lbls2) &&& - eq_ifTvBndrs env tvs1 tvs2 (\ env -> - eq_ifContext env cxt1 cxt2 &&& - eq_ifTypes env args1 args2) +eq_ConDecl env c1 c2 = NotEqual eq_hsFD env (ns1,ms1) (ns2,ms2) = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2 @@ -785,7 +843,6 @@ eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2) \begin{code} ----------------- eqIfIdInfo NoInfo NoInfo = Equal -eqIfIdInfo DiscardedInfo DiscardedInfo = Equal -- Should not happen? eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2 eqIfIdInfo i1 i2 = NotEqual @@ -793,7 +850,7 @@ 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 occ1 a1) (HsWorker occ2 a2) = bool (a1==a2 && occ1==occ2) +eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2) eq_item _ _ = NotEqual ----------------- @@ -808,8 +865,9 @@ eq_ifaceExpr env (IfaceLam b1 body1) (IfaceLam b2 body2) = eq_ifBndr env b1 b2 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 as1) (IfaceCase s2 b2 as2) +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)