diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/CoreToIface.hs | 685 | ||||
| -rw-r--r-- | compiler/GHC/CoreToIface.hs-boot | 18 | ||||
| -rw-r--r-- | compiler/GHC/CoreToStg/Prep.hs | 6 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Types.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Binary.hs | 435 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Env.hs | 298 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Env.hs-boot | 9 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 1917 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Binary.hs | 403 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Debug.hs | 172 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Types.hs | 509 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Ext/Utils.hs | 455 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Load.hs | 1289 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Load.hs-boot | 8 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Rename.hs | 743 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Syntax.hs | 2593 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Tidy.hs | 1487 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type.hs | 2060 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Type.hs-boot | 16 | ||||
| -rw-r--r-- | compiler/GHC/Iface/Utils.hs | 2078 | ||||
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs | 1825 | ||||
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs-boot | 20 | ||||
| -rw-r--r-- | compiler/GHC/Stg/Syntax.hs | 6 |
23 files changed, 17027 insertions, 7 deletions
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs new file mode 100644 index 0000000000..65d0da34af --- /dev/null +++ b/compiler/GHC/CoreToIface.hs @@ -0,0 +1,685 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*] + +-- | Functions for converting Core things to interface file things. +module GHC.CoreToIface + ( -- * Binders + toIfaceTvBndr + , toIfaceTvBndrs + , toIfaceIdBndr + , toIfaceBndr + , toIfaceForAllBndr + , toIfaceTyCoVarBinders + , toIfaceTyVar + -- * Types + , toIfaceType, toIfaceTypeX + , toIfaceKind + , toIfaceTcArgs + , toIfaceTyCon + , toIfaceTyCon_name + , toIfaceTyLit + -- * Tidying types + , tidyToIfaceType + , tidyToIfaceContext + , tidyToIfaceTcArgs + -- * Coercions + , toIfaceCoercion, toIfaceCoercionX + -- * Pattern synonyms + , patSynToIfaceDecl + -- * Expressions + , toIfaceExpr + , toIfaceBang + , toIfaceSrcBang + , toIfaceLetBndr + , toIfaceIdDetails + , toIfaceIdInfo + , toIfUnfolding + , toIfaceOneShot + , toIfaceTickish + , toIfaceBind + , toIfaceAlt + , toIfaceCon + , toIfaceApp + , toIfaceVar + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Iface.Syntax +import DataCon +import Id +import IdInfo +import CoreSyn +import TyCon hiding ( pprPromotionQuote ) +import CoAxiom +import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) +import TysWiredIn ( heqTyCon ) +import MkId ( noinlineIdName ) +import PrelNames +import Name +import BasicTypes +import Type +import PatSyn +import Outputable +import FastString +import Util +import Var +import VarEnv +import VarSet +import TyCoRep +import TyCoTidy ( tidyCo ) +import Demand ( isTopSig ) + +import Data.Maybe ( catMaybes ) + +{- Note [Avoiding space leaks in toIface*] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Building a interface file depends on the output of the simplifier. +If we build these lazily this would mean keeping the Core AST alive +much longer than necessary causing a space "leak". + +This happens for example when we only write the interface file to disk +after code gen has run, in which case we might carry megabytes of core +AST in the heap which is no longer needed. + +We avoid this in two ways. +* First we use -XStrict in GHC.CoreToIface which avoids many thunks + to begin with. +* Second we define NFData instance for Iface syntax and use them to + force any remaining thunks. + +-XStrict is not sufficient as patterns of the form `f (g x)` would still +result in a thunk being allocated for `g x`. + +NFData is sufficient for the space leak, but using -XStrict reduces allocation +by ~0.1% when compiling with -O. (nofib/spectral/simple, T10370). +It's essentially free performance hence we use -XStrict on top of NFData. + +MR !1633 on gitlab, has more discussion on the topic. +-} + +---------------- +toIfaceTvBndr :: TyVar -> IfaceTvBndr +toIfaceTvBndr = toIfaceTvBndrX emptyVarSet + +toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr +toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) + , toIfaceTypeX fr (tyVarKind tyvar) + ) + +toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] +toIfaceTvBndrs = map toIfaceTvBndr + +toIfaceIdBndr :: Id -> IfaceIdBndr +toIfaceIdBndr = toIfaceIdBndrX emptyVarSet + +toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr +toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar) + , toIfaceTypeX fr (varType covar) + ) + +toIfaceBndr :: Var -> IfaceBndr +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +toIfaceBndrX :: VarSet -> Var -> IfaceBndr +toIfaceBndrX fr var + | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) + | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) + +toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis +toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis + +toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] +toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder + +{- +************************************************************************ +* * + Conversion from Type to IfaceType +* * +************************************************************************ +-} + +toIfaceKind :: Type -> IfaceType +toIfaceKind = toIfaceType + +--------------------- +toIfaceType :: Type -> IfaceType +toIfaceType = toIfaceTypeX emptyVarSet + +toIfaceTypeX :: VarSet -> Type -> IfaceType +-- (toIfaceTypeX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +-- +-- Synonyms are retained in the interface type +toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in GHC.Iface.Type + | tv `elemVarSet` fr = IfaceFreeTyVar tv + | otherwise = IfaceTyVar (toIfaceTyVar tv) +toIfaceTypeX fr ty@(AppTy {}) = + -- Flatten as many argument AppTys as possible, then turn them into an + -- IfaceAppArgs list. + -- See Note [Suppressing invisible arguments] in GHC.Iface.Type. + let (head, args) = splitAppTys ty + in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) +toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) + (toIfaceTypeX (fr `delVarSet` binderVar b) t) +toIfaceTypeX fr (FunTy { ft_arg = t1, ft_res = t2, ft_af = af }) + = IfaceFunTy af (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) +toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) +toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) + +toIfaceTypeX fr (TyConApp tc tys) + -- tuples + | Just sort <- tyConTuple_maybe tc + , n_tys == arity + = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys) + + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , n_tys == 2*arity + = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) + + | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] + , (k1:k2:_) <- tys + = let info = IfaceTyConInfo NotPromoted sort + sort | k1 `eqType` k2 = IfaceEqualityTyCon + | otherwise = IfaceNormalTyCon + in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) + + -- other applications + | otherwise + = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) + where + arity = tyConArity tc + n_tys = length tys + +toIfaceTyVar :: TyVar -> FastString +toIfaceTyVar = occNameFS . getOccName + +toIfaceCoVar :: CoVar -> FastString +toIfaceCoVar = occNameFS . getOccName + +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet + +toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis + +---------------- +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc + = IfaceTyCon tc_name info + where + tc_name = tyConName tc + info = IfaceTyConInfo promoted sort + promoted | isPromotedDataCon tc = IsPromoted + | otherwise = NotPromoted + + tupleSort :: TyCon -> Maybe IfaceTyConSort + tupleSort tc' = + case tyConTuple_maybe tc' of + Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 + in Just $ IfaceTupleTyCon arity UnboxedTuple + Just sort -> let arity = tyConArity tc' + in Just $ IfaceTupleTyCon arity sort + Nothing -> Nothing + + sort + | Just tsort <- tupleSort tc = tsort + + | Just dcon <- isPromotedDataCon_maybe tc + , let tc' = dataConTyCon dcon + , Just tsort <- tupleSort tc' = tsort + + | isUnboxedSumTyCon tc + , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) + + | otherwise = IfaceNormalTyCon + + +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name n = IfaceTyCon n info + where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon + -- Used for the "rough-match" tycon stuff, + -- where pretty-printing is not an issue + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x + +---------------- +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion = toIfaceCoercionX emptyVarSet + +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +-- (toIfaceCoercionX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +toIfaceCoercionX fr co + = go co + where + go_mco MRefl = IfaceMRefl + go_mco (MCo co) = IfaceMCo $ go co + + go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) + go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) + go (CoVarCo cv) + -- See [TcTyVars in IfaceType] in GHC.Iface.Type + | cv `elemVarSet` fr = IfaceFreeCoVar cv + | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) + + go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) + go (SymCo co) = IfaceSymCo (go co) + go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) + go (NthCo _r d co) = IfaceNthCo d (go co) + go (LRCo lr co) = IfaceLRCo lr (go co) + go (InstCo co arg) = IfaceInstCo (go co) (go arg) + go (KindCo c) = IfaceKindCo (go c) + go (SubCo co) = IfaceSubCo (go co) + go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) + go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) + go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r + (toIfaceTypeX fr t1) + (toIfaceTypeX fr t2) + go (TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) + | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2) + + go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) + (toIfaceCoercionX fr' k) + (toIfaceCoercionX fr' co) + where + fr' = fr `delVarSet` tv + + go_prov :: UnivCoProvenance -> IfaceUnivCoProv + go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv + go_prov (PhantomProv co) = IfacePhantomProv (go co) + go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) + go_prov (PluginProv str) = IfacePluginProv str + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgs = toIfaceTcArgsX emptyVarSet + +toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args + +toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs +toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args + +toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs +-- See Note [Suppressing invisible arguments] in GHC.Iface.Type +-- We produce a result list of args describing visibility +-- The awkward case is +-- T :: forall k. * -> k +-- And consider +-- T (forall j. blah) * blib +-- Is 'blib' visible? It depends on the visibility flag on j, +-- so we have to substitute for k. Annoying! +toIfaceAppArgsX fr kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = IA_Nil + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + = IA_Arg t' vis ts' + where + t' = toIfaceTypeX fr t + ts' = go (extendTCvSubst env tv t) res ts + + go env (FunTy { ft_af = af, ft_res = res }) (t:ts) + = IA_Arg (toIfaceTypeX fr t) argf (go env res ts) + where + argf = case af of + VisArg -> Required + InvisArg -> Inferred + -- It's rare for a kind to have a constraint argument, but + -- it can happen. See Note [AnonTCB InvisArg] in TyCon. + + go env ty ts@(t1:ts1) + | not (isEmptyTCvSubst env) + = go (zapTCvSubst env) (substTy env ty) ts + -- See Note [Care with kind instantiation] in Type.hs + + | otherwise + = -- There's a kind error in the type we are trying to print + -- e.g. kind = k, ty_args = [Int] + -- This is probably a compiler bug, so we print a trace and + -- carry on as if it were FunTy. Without the test for + -- isEmptyTCvSubst we'd get an infinite loop (#15473) + WARN( True, ppr kind $$ ppr ty_args ) + IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) + +tidyToIfaceType :: TidyEnv -> Type -> IfaceType +tidyToIfaceType env ty = toIfaceType (tidyType env ty) + +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + +tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext +tidyToIfaceContext env theta = map (tidyToIfaceType env) theta + +{- +************************************************************************ +* * + Conversion of pattern synonyms +* * +************************************************************************ +-} + +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getName $ ps + , ifPatMatcher = to_if_pr (patSynMatcher ps) + , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' + , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map (tidyToIfaceType env2) args + , ifPatTy = tidyToIfaceType env2 rhs_ty + , ifFieldLabels = (patSynFieldLabels ps) + } + where + (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps + univ_bndrs = patSynUnivTyVarBinders ps + ex_bndrs = patSynExTyVarBinders ps + (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs + to_if_pr (id, needs_dummy) = (idName id, needs_dummy) + +{- +************************************************************************ +* * + Conversion of other things +* * +************************************************************************ +-} + +toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang +toIfaceBang _ HsLazy = IfNoBang +toIfaceBang _ (HsUnpack Nothing) = IfUnpack +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) +toIfaceBang _ HsStrict = IfStrict + +toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang +toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang + +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) + (toIfaceJoinInfo (isJoinId_maybe id)) + -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr + -- has left on the Id. See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax + +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = + let iface = case tc of + RecSelData ty_con -> Left (toIfaceTyCon ty_con) + RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) + in IfRecSelId iface n + + -- The remaining cases are all "implicit Ids" which don't + -- appear in interface files at all +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected; the other + +toIfaceIdInfo :: IdInfo -> IfaceIdInfo +toIfaceIdInfo id_info + = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + inline_hsinfo, unfold_hsinfo, levity_hsinfo] of + [] -> NoInfo + infos -> HasInfo infos + -- NB: strictness and arity must appear in the list before unfolding + -- See GHC.IfaceToCore.tcUnfolding + 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 + sig_info = strictnessInfo id_info + strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) + | otherwise = Nothing + + ------------ Unfolding -------------- + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + + ------------ Levity polymorphism ---------- + levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity + | otherwise = Nothing + +toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo +toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar +toIfaceJoinInfo Nothing = IfaceNotJoinPoint + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs + , uf_src = src + , uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineStable + -> case guidance of + UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs + InlineCompulsory -> IfCompulsory if_rhs + InlineRhs -> IfCoreUnfold False if_rhs + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, GHC.Iface.Tidy would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + if_rhs = toIfaceExpr rhs + +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ (OtherCon {}) = Nothing + -- The binding site of an Id doesn't have OtherCon, except perhaps + -- where we have called zapUnfolding; and that evald'ness info is + -- not needed by importing modules + +toIfUnfolding _ BootUnfolding = Nothing + -- Can't happen; we only have BootUnfolding for imported binders + +toIfUnfolding _ NoUnfolding = Nothing + +{- +************************************************************************ +* * + Conversion of expressions +* * +************************************************************************ +-} + +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) +toIfaceExpr (Tick t e) + | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) + | otherwise = toIfaceExpr e + +toIfaceOneShot :: Id -> IfaceOneShot +toIfaceOneShot id | isId id + , OneShotLam <- oneShotInfo (idInfo id) + = IfaceOneShot + | otherwise + = IfaceNoOneShot + +--------------------- +toIfaceTickish :: Tickish Id -> Maybe IfaceTickish +toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) +toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) +toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) +toIfaceTickish (Breakpoint {}) = Nothing + -- Ignore breakpoints, since they are relevant only to GHCi, and + -- should not be serialised (#8333) + +--------------------- +toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] + +--------------------- +toIfaceAlt :: (AltCon, [Var], CoreExpr) + -> (IfaceConAlt, [FastString], IfaceExpr) +toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) + +--------------------- +toIfaceCon :: AltCon -> IfaceConAlt +toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | saturated + , Just tup_sort <- tyConTuple_maybe tc + -> IfaceTuple tup_sort tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toIfaceExpr val_args + tc = dataConTyCon dc + + _ -> mkIfaceApps (toIfaceVar v) as + +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as + +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as + +--------------------- +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | isBootUnfolding (idUnfolding v) + = -- See Note [Inlining and hs-boot files] + IfaceApp (IfaceApp (IfaceExt noinlineIdName) + (IfaceType (toIfaceType (idType v)))) + (IfaceExt name) -- don't use mkIfaceApps, or infinite loop + + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getOccFS name) + where name = idName v + + +{- Note [Inlining and hs-boot files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example (#10083, #12789): + + ---------- RSR.hs-boot ------------ + module RSR where + data RSR + eqRSR :: RSR -> RSR -> Bool + + ---------- SR.hs ------------ + module SR where + import {-# SOURCE #-} RSR + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 + + ---------- RSR.hs ------------ + module RSR where + import SR + data RSR = MkRSR SR -- deriving( Eq ) + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) + +When compiling RSR we get this code + + RSR.eqRSR :: RSR -> RSR -> Bool + RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> + case ds1 of _ { RSR.MkRSR s1 -> + case ds2 of _ { RSR.MkRSR s2 -> + SR.eqSR s1 s2 }} + + RSR.foo :: RSR -> RSR -> Bool + RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) + +Now, when optimising foo: + Inline eqRSR (small, non-rec) + Inline eqSR (small, non-rec) +but the result of inlining eqSR from SR is another call to eqRSR, so +everything repeats. Neither eqSR nor eqRSR are (apparently) loop +breakers. + +Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR +with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means +that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly +as would have been the case if `foo` had been defined in SR.hs (and +marked as a loop-breaker). + +But how do we arrange for this to happen? There are two ingredients: + + 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), + for every variable reference we see if we are referring to an + 'Id' that came from an hs-boot file. If so, we add a `noinline` + to the reference. + + 2. But how do we know if a reference came from an hs-boot file + or not? We could record this directly in the 'IdInfo', but + actually we deduce this by looking at the unfolding: 'Id's + that come from boot files are given a special unfolding + (upon typechecking) 'BootUnfolding' which say that there is + no unfolding, and the reason is because the 'Id' came from + a boot file. + +Here is a solution that doesn't work: when compiling RSR, +add a NOINLINE pragma to every function exported by the boot-file +for RSR (if it exists). Doing so makes the bootstrapped GHC itself +slower by 8% overall (on #9872a-d, and T1969: the reason +is that these NOINLINE'd functions now can't be profitably inlined +outside of the hs-boot loop. + +-} diff --git a/compiler/GHC/CoreToIface.hs-boot b/compiler/GHC/CoreToIface.hs-boot new file mode 100644 index 0000000000..24fb1a148b --- /dev/null +++ b/compiler/GHC/CoreToIface.hs-boot @@ -0,0 +1,18 @@ +module GHC.CoreToIface where + +import {-# SOURCE #-} TyCoRep ( Type, TyLit, Coercion ) +import {-# SOURCE #-} GHC.Iface.Type( IfaceType, IfaceTyCon, IfaceForAllBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) +import Var ( TyCoVarBinder ) +import VarEnv ( TidyEnv ) +import TyCon ( TyCon ) +import VarSet( VarSet ) + +-- For TyCoRep +toIfaceTypeX :: VarSet -> Type -> IfaceType +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index ea020c5f9e..1512ab3842 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -228,7 +228,7 @@ corePrepTopBinds initialCorePrepEnv binds mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind] -- See Note [Data constructor workers] --- c.f. Note [Injecting implicit bindings] in TidyPgm +-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy mkDataConWorkers dflags mod_loc data_tycons = [ NonRec id (tick_it (getName data_con) (Var id)) -- The ice is thin here, but it works @@ -1070,8 +1070,8 @@ unsaturated applications (identified by 'hasNoBinding', currently just foreign calls and unboxed tuple/sum constructors). Note that eta expansion in CorePrep is very fragile due to the "prediction" of -CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta -expansion in CorePrep] in TidyPgm for details. We previously saturated primop +CAFfyness made during tidying (see Note [CAFfyness inconsistencies due to eta +expansion in CorePrep] in GHC.Iface.Tidy for details. We previously saturated primop applications here as well but due to this fragility (see #16846) we now deal with this another way, as described in Note [Primop wrappers] in PrimOp. diff --git a/compiler/GHC/Hs/Types.hs b/compiler/GHC/Hs/Types.hs index 324b1dd3d2..46cc1ecb24 100644 --- a/compiler/GHC/Hs/Types.hs +++ b/compiler/GHC/Hs/Types.hs @@ -1686,7 +1686,7 @@ hsTypeNeedsParens p = go maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc -- See Note [Printing promoted type constructors] --- in IfaceType. This code implements the same +-- in GHC.Iface.Type. This code implements the same -- logic for printing HsType maybeAddSpace tys doc | (ty : _) <- tys diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs new file mode 100644 index 0000000000..af0e9bfac6 --- /dev/null +++ b/compiler/GHC/Iface/Binary.hs @@ -0,0 +1,435 @@ +{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-} + +-- +-- (c) The University of Glasgow 2002-2006 +-- + +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | Binary interface file support. +module GHC.Iface.Binary ( + -- * Public API for interface file serialisation + writeBinIface, + readBinIface, + getSymtabName, + getDictFastString, + CheckHiWay(..), + TraceBinIFaceReading(..), + getWithUserData, + putWithUserData, + + -- * Internal serialisation functions + getSymbolTable, + putName, + putDictionary, + putFastString, + putSymbolTable, + BinSymbolTable(..), + BinDictionary(..) + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcRnMonad +import PrelInfo ( isKnownKeyName, lookupKnownKeyName ) +import GHC.Iface.Env +import HscTypes +import Module +import Name +import DynFlags +import UniqFM +import UniqSupply +import Panic +import Binary +import SrcLoc +import ErrUtils +import FastMutInt +import Unique +import Outputable +import NameCache +import GHC.Platform +import FastString +import Constants +import Util + +import Data.Array +import Data.Array.ST +import Data.Array.Unsafe +import Data.Bits +import Data.Char +import Data.Word +import Data.IORef +import Data.Foldable +import Control.Monad +import Control.Monad.ST +import Control.Monad.Trans.Class +import qualified Control.Monad.Trans.State.Strict as State + +-- --------------------------------------------------------------------------- +-- Reading and writing binary interface files +-- + +data CheckHiWay = CheckHiWay | IgnoreHiWay + deriving Eq + +data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading + deriving Eq + +-- | Read an interface file +readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath + -> TcRnIf a b ModIface +readBinIface checkHiWay traceBinIFaceReading hi_path = do + ncu <- mkNameCacheUpdater + dflags <- getDynFlags + liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu + +readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath + -> NameCacheUpdater + -> IO ModIface +readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do + let printer :: SDoc -> IO () + printer = case traceBinIFaceReading of + TraceBinIFaceReading -> \sd -> + putLogMsg dflags + NoReason + SevOutput + noSrcSpan + (defaultDumpStyle dflags) + sd + QuietBinIFaceReading -> \_ -> return () + + wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () + wantedGot what wanted got ppr' = + printer (text what <> text ": " <> + vcat [text "Wanted " <> ppr' wanted <> text ",", + text "got " <> ppr' got]) + + errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO () + errorOnMismatch what wanted got = + -- This will be caught by readIface which will emit an error + -- msg containing the iface module name. + when (wanted /= got) $ throwGhcExceptionIO $ ProgramError + (what ++ " (wanted " ++ show wanted + ++ ", got " ++ show got ++ ")") + bh <- Binary.readBinMem hi_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr + errorOnMismatch "magic number mismatch: old/corrupt interface file?" + (binaryInterfaceMagic dflags) magic + + -- Note [dummy iface field] + -- read a dummy 32/64 bit value. This field used to hold the + -- dictionary pointer in old interface file formats, but now + -- the dictionary pointer is after the version (where it + -- should be). Also, the serialisation of value of type "Bin + -- a" used to depend on the word size of the machine, now they + -- are always 32 bits. + if wORD_SIZE dflags == 4 + then do _ <- Binary.get bh :: IO Word32; return () + else do _ <- Binary.get bh :: IO Word64; return () + + -- Check the interface file version and ways. + check_ver <- get bh + let our_ver = show hiVersion + wantedGot "Version" our_ver check_ver text + errorOnMismatch "mismatched interface file versions" our_ver check_ver + + check_way <- get bh + let way_descr = getWayDescr dflags + wantedGot "Way" way_descr check_way ppr + when (checkHiWay == CheckHiWay) $ + errorOnMismatch "mismatched interface file ways" way_descr check_way + getWithUserData ncu bh + + +-- | This performs a get action after reading the dictionary and symbol +-- table. It is necessary to run this before trying to deserialise any +-- Names or FastStrings. +getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a +getWithUserData ncu bh = do + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Binary.get bh + data_p <- tellBin bh -- Remember where we are now + seekBin bh dict_p + dict <- getDictionary bh + seekBin bh data_p -- Back to where we were before + + -- Initialise the user-data field of bh + bh <- do + bh <- return $ setUserData bh $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab_p <- Binary.get bh -- Get the symtab ptr + data_p <- tellBin bh -- Remember where we are now + seekBin bh symtab_p + symtab <- getSymbolTable bh ncu + seekBin bh data_p -- Back to where we were before + + -- It is only now that we know how to get a Name + return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab) + (getDictFastString dict) + + -- Read the interface file + get bh + +-- | Write an interface file +writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () +writeBinIface dflags hi_path mod_iface = do + bh <- openBinMem initBinMemSize + put_ bh (binaryInterfaceMagic dflags) + + -- dummy 32/64-bit field before the version/way for + -- compatibility with older interface file formats. + -- See Note [dummy iface field] above. + if wORD_SIZE dflags == 4 + then Binary.put_ bh (0 :: Word32) + else Binary.put_ bh (0 :: Word64) + + -- The version and way descriptor go next + put_ bh (show hiVersion) + let way_descr = getWayDescr dflags + put_ bh way_descr + + + putWithUserData (debugTraceMsg dflags 3) bh mod_iface + -- And send the result to the file + writeBinMem bh hi_path + +-- | Put a piece of data with an initialised `UserData` field. This +-- is necessary if you want to serialise Names or FastStrings. +-- It also writes a symbol table and the dictionary. +-- This segment should be read using `getWithUserData`. +putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO () +putWithUserData log_action bh payload = do + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + -- Placeholder for ptr to dictionary + put_ bh dict_p_p + + -- Remember where the symbol table pointer will go + symtab_p_p <- tellBin bh + put_ bh symtab_p_p + -- Make some initial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = BinSymbolTable { + bin_symtab_next = symtab_next, + bin_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = BinDictionary { + bin_dict_next = dict_next_ref, + bin_dict_map = dict_map_ref } + + -- Put the main thing, + bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab) + (putName bin_dict bin_symtab) + (putFastString bin_dict) + put_ bh payload + + -- Write the symtab pointer at the front of the file + symtab_p <- tellBin bh -- This is where the symtab will start + putAt bh symtab_p_p symtab_p -- Fill in the placeholder + seekBin bh symtab_p -- Seek back to the end of the file + + -- Write the symbol table itself + symtab_next <- readFastMutInt symtab_next + symtab_map <- readIORef symtab_map + putSymbolTable bh symtab_next symtab_map + log_action (text "writeBinIface:" <+> int symtab_next + <+> text "Names") + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + + -- Write the dictionary pointer at the front of the file + dict_p <- tellBin bh -- This is where the dictionary will start + putAt bh dict_p_p dict_p -- Fill in the placeholder + seekBin bh dict_p -- Seek back to the end of the file + + -- Write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + log_action (text "writeBinIface:" <+> int dict_next + <+> text "dict entries") + + + +-- | Initial ram buffer to allocate for writing interface files +initBinMemSize :: Int +initBinMemSize = 1024 * 1024 + +binaryInterfaceMagic :: DynFlags -> Word32 +binaryInterfaceMagic dflags + | target32Bit (targetPlatform dflags) = 0x1face + | otherwise = 0x1face64 + + +-- ----------------------------------------------------------------------------- +-- The symbol table +-- + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) + -- It's OK to use nonDetEltsUFM here because the elements have + -- indices that array uses to create order + mapM_ (\n -> serialiseName bh n symtab) names + +getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable +getSymbolTable bh ncu = do + sz <- get bh + od_names <- sequence (replicate sz (get bh)) + updateNameCache ncu $ \namecache -> + runST $ flip State.evalStateT namecache $ do + mut_arr <- lift $ newSTArray_ (0, sz-1) + for_ (zip [0..] od_names) $ \(i, odn) -> do + (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn + lift $ writeArray mut_arr i n + State.put nc + arr <- lift $ unsafeFreeze mut_arr + namecache' <- State.get + return (namecache', arr) + where + -- This binding is required because the type of newArray_ cannot be inferred + newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name) + newSTArray_ = newArray_ + +type OnDiskName = (UnitId, ModuleName, OccName) + +fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name) +fromOnDiskName nc (pid, mod_name, occ) = + let mod = mkModule pid mod_name + cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName bh name _ = do + let mod = ASSERT2( isExternalName name, ppr name ) nameModule name + put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) + + +-- Note [Symbol table representation of names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- An occurrence of a name in an interface file is serialized as a single 32-bit +-- word. The format of this word is: +-- 00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx +-- A normal name. x is an index into the symbol table +-- 10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy +-- A known-key name. x is the Unique's Char, y is the int part. We assume that +-- all known-key uniques fit in this space. This is asserted by +-- PrelInfo.knownKeyNamesOkay. +-- +-- During serialization we check for known-key things using isKnownKeyName. +-- During deserialization we use lookupKnownKeyName to get from the unique back +-- to its corresponding Name. + + +-- See Note [Symbol table representation of names] +putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName _dict BinSymbolTable{ + bin_symtab_map = symtab_map_ref, + bin_symtab_next = symtab_next } + bh name + | isKnownKeyName name + , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits + = -- ASSERT(u < 2^(22 :: Int)) + put_ bh (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) + + | otherwise + = do symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + -- MASSERT(off < 2^(30 :: Int)) + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + +-- See Note [Symbol table representation of names] +getSymtabName :: NameCacheUpdater + -> Dictionary -> SymbolTable + -> BinHandle -> IO Name +getSymtabName _ncu _dict symtab bh = do + i :: Word32 <- get bh + case i .&. 0xC0000000 of + 0x00000000 -> return $! symtab ! fromIntegral i + + 0x80000000 -> + let + tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22)) + ix = fromIntegral i .&. 0x003FFFFF + u = mkUnique tag ix + in + return $! case lookupKnownKeyName u of + Nothing -> pprPanic "getSymtabName:unknown known-key unique" + (ppr i $$ ppr (unpkUnique u)) + Just n -> n + + _ -> pprPanic "getSymtabName:unknown name tag" (ppr i) + +data BinSymbolTable = BinSymbolTable { + bin_symtab_next :: !FastMutInt, -- The next index to use + bin_symtab_map :: !(IORef (UniqFM (Int,Name))) + -- indexed by Name + } + +putFastString :: BinDictionary -> BinHandle -> FastString -> IO () +putFastString dict bh fs = allocateFastString dict fs >>= put_ bh + +allocateFastString :: BinDictionary -> FastString -> IO Word32 +allocateFastString BinDictionary { bin_dict_next = j_r, + bin_dict_map = out_r} f = do + out <- readIORef out_r + let uniq = getUnique f + case lookupUFM out uniq of + Just (j, _) -> return (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out uniq (j, f) + return (fromIntegral j :: Word32) + +getDictFastString :: Dictionary -> BinHandle -> IO FastString +getDictFastString dict bh = do + j <- get bh + return $! (dict ! fromIntegral (j :: Word32)) + +data BinDictionary = BinDictionary { + bin_dict_next :: !FastMutInt, -- The next index to use + bin_dict_map :: !(IORef (UniqFM (Int,FastString))) + -- indexed by FastString + } + +getWayDescr :: DynFlags -> String +getWayDescr dflags + | platformUnregisterised (targetPlatform dflags) = 'u':tag + | otherwise = tag + where tag = buildTag dflags + -- if this is an unregisterised build, make sure our interfaces + -- can't be used by a registerised build. diff --git a/compiler/GHC/Iface/Env.hs b/compiler/GHC/Iface/Env.hs new file mode 100644 index 0000000000..fcb1e2dcfb --- /dev/null +++ b/compiler/GHC/Iface/Env.hs @@ -0,0 +1,298 @@ +-- (c) The University of Glasgow 2002-2006 + +{-# LANGUAGE CPP, RankNTypes, BangPatterns #-} + +module GHC.Iface.Env ( + newGlobalBinder, newInteractiveBinder, + externaliseName, + lookupIfaceTop, + lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache, + newIfaceName, newIfaceNames, + extendIfaceIdEnv, extendIfaceTyVarEnv, + tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar, + lookupIfaceTyVar, extendIfaceEnvs, + setNameModule, + + ifaceExportNames, + + -- Name-cache stuff + allocateGlobalBinder, updNameCacheTc, + mkNameCacheUpdater, NameCacheUpdater(..), + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcRnMonad +import HscTypes +import Type +import Var +import Name +import Avail +import Module +import FastString +import FastStringEnv +import GHC.Iface.Type +import NameCache +import UniqSupply +import SrcLoc + +import Outputable +import Data.List ( partition ) + +{- +********************************************************* +* * + Allocating new Names in the Name Cache +* * +********************************************************* + +See Also: Note [The Name Cache] in NameCache +-} + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name +-- Used for source code and interface files, to make the +-- Name for a thing, given its Module and OccName +-- See Note [The Name Cache] +-- +-- The cache may already already have a binding for this thing, +-- because we may have seen an occurrence before, but now is the +-- moment when we know its Module and SrcLoc in their full glory + +newGlobalBinder mod occ loc + = do { name <- updNameCacheTc mod occ $ \name_cache -> + allocateGlobalBinder name_cache mod occ loc + ; traceIf (text "newGlobalBinder" <+> + (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name])) + ; return name } + +newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name +-- Works in the IO monad, and gets the Module +-- from the interactive context +newInteractiveBinder hsc_env occ loc + = do { let mod = icInteractiveModule (hsc_IC hsc_env) + ; updNameCacheIO hsc_env mod occ $ \name_cache -> + allocateGlobalBinder name_cache mod occ loc } + +allocateGlobalBinder + :: NameCache + -> Module -> OccName -> SrcSpan + -> (NameCache, Name) +-- See Note [The Name Cache] +allocateGlobalBinder name_supply mod occ loc + = case lookupOrigNameCache (nsNames name_supply) mod occ of + -- A hit in the cache! We are at the binding site of the name. + -- This is the moment when we know the SrcLoc + -- of the Name, so we set this field in the Name we return. + -- + -- Then (bogus) multiple bindings of the same Name + -- get different SrcLocs can be reported as such. + -- + -- Possible other reason: it might be in the cache because we + -- encountered an occurrence before the binding site for an + -- implicitly-imported Name. Perhaps the current SrcLoc is + -- better... but not really: it'll still just say 'imported' + -- + -- IMPORTANT: Don't mess with wired-in names. + -- Their wired-in-ness is in their NameSort + -- and their Module is correct. + + Just name | isWiredInName name + -> (name_supply, name) + | otherwise + -> (new_name_supply, name') + where + uniq = nameUnique name + name' = mkExternalName uniq mod occ loc + -- name' is like name, but with the right SrcSpan + new_cache = extendNameCache (nsNames name_supply) mod occ name' + new_name_supply = name_supply {nsNames = new_cache} + + -- Miss in the cache! + -- Build a completely new Name, and put it in the cache + _ -> (new_name_supply, name) + where + (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) + name = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} + +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] +ifaceExportNames exports = return exports + +-- | A function that atomically updates the name cache given a modifier +-- function. The second result of the modifier function will be the result +-- of the IO action. +newtype NameCacheUpdater + = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c } + +mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater +mkNameCacheUpdater = do { hsc_env <- getTopEnv + ; let !ncRef = hsc_NC hsc_env + ; return (NCU (updNameCache ncRef)) } + +updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c)) + -> TcRnIf a b c +updNameCacheTc mod occ upd_fn = do { + hsc_env <- getTopEnv + ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn } + + +updNameCacheIO :: HscEnv -> Module -> OccName + -> (NameCache -> (NameCache, c)) + -> IO c +updNameCacheIO hsc_env mod occ upd_fn = do { + + -- First ensure that mod and occ are evaluated + -- If not, chaos can ensue: + -- we read the name-cache + -- then pull on mod (say) + -- which does some stuff that modifies the name cache + -- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..) + + mod `seq` occ `seq` return () + ; updNameCache (hsc_NC hsc_env) upd_fn } + + +{- +************************************************************************ +* * + Name cache access +* * +************************************************************************ +-} + +-- | Look up the 'Name' for a given 'Module' and 'OccName'. +-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad +-- and 'Module' is simply that of the 'ModIface' you are typechecking. +lookupOrig :: Module -> OccName -> TcRnIf a b Name +lookupOrig mod occ + = do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) + + ; updNameCacheTc mod occ $ lookupNameCache mod occ } + +lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name +lookupOrigIO hsc_env mod occ + = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ + +lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name) +-- Lookup up the (Module,OccName) in the NameCache +-- If you find it, return it; if not, allocate a fresh original name and extend +-- the NameCache. +-- Reason: this may the first occurrence of (say) Foo.bar we have encountered. +-- If we need to explore its value we will load Foo.hi; but meanwhile all we +-- need is a Name for it. +lookupNameCache mod occ name_cache = + case lookupOrigNameCache (nsNames name_cache) mod occ of { + Just name -> (name_cache, name); + Nothing -> + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }} + +externaliseName :: Module -> Name -> TcRnIf m n Name +-- Take an Internal Name and make it an External one, +-- with the same unique +externaliseName mod name + = do { let occ = nameOccName name + loc = nameSrcSpan name + uniq = nameUnique name + ; occ `seq` return () -- c.f. seq in newGlobalBinder + ; updNameCacheTc mod occ $ \ ns -> + let name' = mkExternalName uniq mod occ loc + ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' } + in (ns', name') } + +-- | Set the 'Module' of a 'Name'. +setNameModule :: Maybe Module -> Name -> TcRnIf m n Name +setNameModule Nothing n = return n +setNameModule (Just m) n = + newGlobalBinder m (nameOccName n) (nameSrcSpan n) + +{- +************************************************************************ +* * + Type variables and local Ids +* * +************************************************************************ +-} + +tcIfaceLclId :: FastString -> IfL Id +tcIfaceLclId occ + = do { lcl <- getLclEnv + ; case (lookupFsEnv (if_id_env lcl) occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ) + } + +extendIfaceIdEnv :: [Id] -> IfL a -> IfL a +extendIfaceIdEnv ids thing_inside + = do { env <- getLclEnv + ; let { id_env' = extendFsEnvList (if_id_env env) pairs + ; pairs = [(occNameFS (getOccName id), id) | id <- ids] } + ; setLclEnv (env { if_id_env = id_env' }) thing_inside } + + +tcIfaceTyVar :: FastString -> IfL TyVar +tcIfaceTyVar occ + = do { lcl <- getLclEnv + ; case (lookupFsEnv (if_tv_env lcl) occ) of + Just ty_var -> return ty_var + Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ) + } + +lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar) +lookupIfaceTyVar (occ, _) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_tv_env lcl) occ) } + +lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar) +lookupIfaceVar (IfaceIdBndr (occ, _)) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_id_env lcl) occ) } +lookupIfaceVar (IfaceTvBndr (occ, _)) + = do { lcl <- getLclEnv + ; return (lookupFsEnv (if_tv_env lcl) occ) } + +extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a +extendIfaceTyVarEnv tyvars thing_inside + = do { env <- getLclEnv + ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs + ; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] } + ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside } + +extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a +extendIfaceEnvs tcvs thing_inside + = extendIfaceTyVarEnv tvs $ + extendIfaceIdEnv cvs $ + thing_inside + where + (tvs, cvs) = partition isTyVar tcvs + +{- +************************************************************************ +* * + Getting from RdrNames to Names +* * +************************************************************************ +-} + +-- | Look up a top-level name from the current Iface module +lookupIfaceTop :: OccName -> IfL Name +lookupIfaceTop occ + = do { env <- getLclEnv; lookupOrig (if_mod env) occ } + +newIfaceName :: OccName -> IfL Name +newIfaceName occ + = do { uniq <- newUnique + ; return $! mkInternalName uniq occ noSrcSpan } + +newIfaceNames :: [OccName] -> IfL [Name] +newIfaceNames occs + = do { uniqs <- newUniqueSupply + ; return [ mkInternalName uniq occ noSrcSpan + | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] } diff --git a/compiler/GHC/Iface/Env.hs-boot b/compiler/GHC/Iface/Env.hs-boot new file mode 100644 index 0000000000..2c326ab0ad --- /dev/null +++ b/compiler/GHC/Iface/Env.hs-boot @@ -0,0 +1,9 @@ +module GHC.Iface.Env where + +import Module +import OccName +import TcRnMonad +import Name +import SrcLoc + +newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs new file mode 100644 index 0000000000..03ccc6bdd4 --- /dev/null +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -0,0 +1,1917 @@ +{- +Main functions for .hie file generation +-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +module GHC.Iface.Ext.Ast ( mkHieFile ) where + +import GhcPrelude + +import Avail ( Avails ) +import Bag ( Bag, bagToList ) +import BasicTypes +import BooleanFormula +import Class ( FunDep ) +import CoreUtils ( exprType ) +import ConLike ( conLikeName ) +import Desugar ( deSugarExpr ) +import FieldLabel +import GHC.Hs +import HscTypes +import Module ( ModuleName, ml_hs_file ) +import MonadUtils ( concatMapM, liftIO ) +import Name ( Name, nameSrcSpan, setNameLoc ) +import NameEnv ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv ) +import SrcLoc +import TcHsSyn ( hsLitType, hsPatType ) +import Type ( mkVisFunTys, Type ) +import TysWiredIn ( mkListTy, mkSumTy ) +import Var ( Id, Var, setVarName, varName, varType ) +import TcRnTypes +import GHC.Iface.Utils ( mkIfaceExports ) +import Panic + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Utils + +import qualified Data.Array as A +import qualified Data.ByteString as BS +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Data ( Data, Typeable ) +import Data.List ( foldl1' ) +import Data.Maybe ( listToMaybe ) +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class ( lift ) + +{- Note [Updating HieAst for changes in the GHC AST] + +When updating the code in this file for changes in the GHC AST, you +need to pay attention to the following things: + +1) Symbols (Names/Vars/Modules) in the following categories: + + a) Symbols that appear in the source file that directly correspond to + something the user typed + b) Symbols that don't appear in the source, but should be in some sense + "visible" to a user, particularly via IDE tooling or the like. This + includes things like the names introduced by RecordWildcards (We record + all the names introduced by a (..) in HIE files), and will include implicit + parameters and evidence variables after one of my pending MRs lands. + +2) Subtrees that may contain such symbols, or correspond to a SrcSpan in + the file. This includes all `Located` things + +For 1), you need to call `toHie` for one of the following instances + +instance ToHie (Context (Located Name)) where ... +instance ToHie (Context (Located Var)) where ... +instance ToHie (IEContext (Located ModuleName)) where ... + +`Context` is a data type that looks like: + +data Context a = C ContextInfo a -- Used for names and bindings + +`ContextInfo` is defined in `GHC.Iface.Ext.Types`, and looks like + +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + ... + +It is used to annotate symbols in the .hie files with some extra information on +the context in which they occur and should be fairly self explanatory. You need +to select one that looks appropriate for the symbol usage. In very rare cases, +you might need to extend this sum type if none of the cases seem appropriate. + +So, given a `Located Name` that is just being "used", and not defined at a +particular location, you would do the following: + + toHie $ C Use located_name + +If you select one that corresponds to a binding site, you will need to +provide a `Scope` and a `Span` for your binding. Both of these are basically +`SrcSpans`. + +The `SrcSpan` in the `Scope` is supposed to span over the part of the source +where the symbol can be legally allowed to occur. For more details on how to +calculate this, see Note [Capturing Scopes and other non local information] +in GHC.Iface.Ext.Ast. + +The binding `Span` is supposed to be the span of the entire binding for +the name. + +For a function definition `foo`: + +foo x = x + y + where y = x^2 + +The binding `Span` is the span of the entire function definition from `foo x` +to `x^2`. For a class definition, this is the span of the entire class, and +so on. If this isn't well defined for your bit of syntax (like a variable +bound by a lambda), then you can just supply a `Nothing` + +There is a test that checks that all symbols in the resulting HIE file +occur inside their stated `Scope`. This can be turned on by passing the +-fvalidate-ide-info flag to ghc along with -fwrite-ide-info to generate the +.hie file. + +You may also want to provide a test in testsuite/test/hiefile that includes +a file containing your new construction, and tests that the calculated scope +is valid (by using -fvalidate-ide-info) + +For subtrees in the AST that may contain symbols, the procedure is fairly +straightforward. If you are extending the GHC AST, you will need to provide a +`ToHie` instance for any new types you may have introduced in the AST. + +Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)): + + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + ... + HsApp _ a b -> + [ toHie a + , toHie b + ] + +If your subtree is `Located` or has a `SrcSpan` available, the output list +should contain a HieAst `Node` corresponding to the subtree. You can use +either `makeNode` or `getTypeNode` for this purpose, depending on whether it +makes sense to assign a `Type` to the subtree. After this, you just need +to concatenate the result of calling `toHie` on all subexpressions and +appropriately annotated symbols contained in the subtree. + +The code above from the ToHie instance of `LhsExpr (GhcPass p)` is supposed +to work for both the renamed and typechecked source. `getTypeNode` is from +the `HasType` class defined in this file, and it has different instances +for `GhcTc` and `GhcRn` that allow it to access the type of the expression +when given a typechecked AST: + +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = ... -- Actually get the type for this expression +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn -- Fallback to a regular `makeNode` without recording the type + +If your subtree doesn't have a span available, you can omit the `makeNode` +call and just recurse directly in to the subexpressions. + +-} + +-- These synonyms match those defined in main/GHC.hs +type RenamedSource = ( HsGroup GhcRn, [LImportDecl GhcRn] + , Maybe [(LIE GhcRn, Avails)] + , Maybe LHsDocString ) +type TypecheckedSource = LHsBinds GhcTc + + +{- Note [Name Remapping] +The Typechecker introduces new names for mono names in AbsBinds. +We don't care about the distinction between mono and poly bindings, +so we replace all occurrences of the mono name with the poly name. +-} +newtype HieState = HieState + { name_remapping :: NameEnv Id + } + +initState :: HieState +initState = HieState emptyNameEnv + +class ModifyState a where -- See Note [Name Remapping] + addSubstitution :: a -> a -> HieState -> HieState + +instance ModifyState Name where + addSubstitution _ _ hs = hs + +instance ModifyState Id where + addSubstitution mono poly hs = + hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} + +modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState +modifyState = foldr go id + where + go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f + go _ f = f + +type HieM = ReaderT HieState Hsc + +-- | Construct an 'HieFile' from the outputs of the typechecker. +mkHieFile :: ModSummary + -> TcGblEnv + -> RenamedSource -> Hsc HieFile +mkHieFile ms ts rs = do + let tc_binds = tcg_binds ts + (asts', arr) <- getCompressedAsts tc_binds rs + let Just src_file = ml_hs_file $ ms_location ms + src <- liftIO $ BS.readFile src_file + return $ HieFile + { hie_hs_file = src_file + , hie_module = ms_mod ms + , hie_types = arr + , hie_asts = asts' + -- mkIfaceExports sorts the AvailInfos for stability + , hie_exports = mkIfaceExports (tcg_exports ts) + , hie_hs_src = src + } + +getCompressedAsts :: TypecheckedSource -> RenamedSource + -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +getCompressedAsts ts rs = do + asts <- enrichHie ts rs + return $ compressTypes asts + +enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type) +enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do + tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts + rasts <- processGrp hsGrp + imps <- toHie $ filter (not . ideclImplicit . unLoc) imports + exps <- toHie $ fmap (map $ IEC Export . fst) exports + let spanFile children = case children of + [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1) + _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children) + (realSrcSpanEnd $ nodeSpan $ last children) + + modulify xs = + Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs + + asts = HieASTs + $ resolveTyVarScopes + $ M.map (modulify . mergeSortAsts) + $ M.fromListWith (++) + $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts + + flat_asts = concat + [ tasts + , rasts + , imps + , exps + ] + return asts + where + processGrp grp = concatM + [ toHie $ fmap (RS ModuleScope ) hs_valds grp + , toHie $ hs_splcds grp + , toHie $ hs_tyclds grp + , toHie $ hs_derivds grp + , toHie $ hs_fixds grp + , toHie $ hs_defds grp + , toHie $ hs_fords grp + , toHie $ hs_warnds grp + , toHie $ hs_annds grp + , toHie $ hs_ruleds grp + ] + +getRealSpan :: SrcSpan -> Maybe Span +getRealSpan (RealSrcSpan sp) = Just sp +getRealSpan _ = Nothing + +grhss_span :: GRHSs p body -> SrcSpan +grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs) +grhss_span (XGRHSs _) = panic "XGRHS has no span" + +bindingsOnly :: [Context Name] -> [HieAST a] +bindingsOnly [] = [] +bindingsOnly (C c n : xs) = case nameSrcSpan n of + RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs + where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info) + info = mempty{identInfo = S.singleton c} + _ -> bindingsOnly xs + +concatM :: Monad m => [m [a]] -> m [a] +concatM xs = concat <$> sequence xs + +{- Note [Capturing Scopes and other non local information] +toHie is a local tranformation, but scopes of bindings cannot be known locally, +hence we have to push the relevant info down into the binding nodes. +We use the following types (*Context and *Scoped) to wrap things and +carry the required info +(Maybe Span) always carries the span of the entire binding, including rhs +-} +data Context a = C ContextInfo a -- Used for names and bindings + +data RContext a = RC RecFieldContext a +data RFContext a = RFC RecFieldContext (Maybe Span) a +-- ^ context for record fields + +data IEContext a = IEC IEType a +-- ^ context for imports/exports + +data BindContext a = BC BindType Scope a +-- ^ context for imports/exports + +data PatSynFieldContext a = PSC (Maybe Span) a +-- ^ context for pattern synonym fields. + +data SigContext a = SC SigInfo a +-- ^ context for type signatures + +data SigInfo = SI SigType (Maybe Span) + +data SigType = BindSig | ClassSig | InstSig + +data RScoped a = RS Scope a +-- ^ Scope spans over everything to the right of a, (mostly) not +-- including a itself +-- (Includes a in a few special cases like recursive do bindings) or +-- let/where bindings + +-- | Pattern scope +data PScoped a = PS (Maybe Span) + Scope -- ^ use site of the pattern + Scope -- ^ pattern to the right of a, not including a + a + deriving (Typeable, Data) -- Pattern Scope + +{- Note [TyVar Scopes] +Due to -XScopedTypeVariables, type variables can be in scope quite far from +their original binding. We resolve the scope of these type variables +in a separate pass +-} +data TScoped a = TS TyVarScope a -- TyVarScope + +data TVScoped a = TVS TyVarScope Scope a -- TyVarScope +-- ^ First scope remains constant +-- Second scope is used to build up the scope of a tyvar over +-- things to its right, ala RScoped + +-- | Each element scopes over the elements to the right +listScopes :: Scope -> [Located a] -> [RScoped (Located a)] +listScopes _ [] = [] +listScopes rhsScope [pat] = [RS rhsScope pat] +listScopes rhsScope (pat : pats) = RS sc pat : pats' + where + pats'@((RS scope p):_) = listScopes rhsScope pats + sc = combineScopes scope $ mkScope $ getLoc p + +-- | 'listScopes' specialised to 'PScoped' things +patScopes + :: Maybe Span + -> Scope + -> Scope + -> [LPat (GhcPass p)] + -> [PScoped (LPat (GhcPass p))] +patScopes rsp useScope patScope xs = + map (\(RS sc a) -> PS rsp useScope sc a) $ + listScopes patScope xs + +-- | 'listScopes' specialised to 'TVScoped' things +tvScopes + :: TyVarScope + -> Scope + -> [LHsTyVarBndr a] + -> [TVScoped (LHsTyVarBndr a)] +tvScopes tvScope rhsScope xs = + map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs + +{- Note [Scoping Rules for SigPat] +Explicitly quantified variables in pattern type signatures are not +brought into scope in the rhs, but implicitly quantified variables +are (HsWC and HsIB). +This is unlike other signatures, where explicitly quantified variables +are brought into the RHS Scope +For example +foo :: forall a. ...; +foo = ... -- a is in scope here + +bar (x :: forall a. a -> a) = ... -- a is not in scope here +-- ^ a is in scope here (pattern body) + +bax (x :: a) = ... -- a is in scope here +Because of HsWC and HsIB pass on their scope to their children +we must wrap the LHsType in pattern signatures in a +Shielded explicitly, so that the HsWC/HsIB scope is not passed +on the the LHsType +-} + +data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead + +type family ProtectedSig a where + ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs + GhcRn + (Shielded (LHsType GhcRn))) + ProtectedSig GhcTc = NoExtField + +class ProtectSig a where + protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a + +instance (HasLoc a) => HasLoc (Shielded a) where + loc (SH _ a) = loc a + +instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where + toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a) + +instance ProtectSig GhcTc where + protectSig _ _ = noExtField + +instance ProtectSig GhcRn where + protectSig sc (HsWC a (HsIB b sig)) = + HsWC a (HsIB b (SH sc sig)) + protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec + protectSig _ (XHsWildCardBndrs nec) = noExtCon nec + +class HasLoc a where + -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can + -- know what their implicit bindings are scoping over + loc :: a -> SrcSpan + +instance HasLoc thing => HasLoc (TScoped thing) where + loc (TS _ a) = loc a + +instance HasLoc thing => HasLoc (PScoped thing) where + loc (PS _ _ _ a) = loc a + +instance HasLoc (LHsQTyVars GhcRn) where + loc (HsQTvs _ vs) = loc vs + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where + loc (HsIB _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where + loc (HsWC _ a) = loc a + loc _ = noSrcSpan + +instance HasLoc (Located a) where + loc (L l _) = l + +instance HasLoc a => HasLoc [a] where + loc [] = noSrcSpan + loc xs = foldl1' combineSrcSpans $ map loc xs + +instance HasLoc a => HasLoc (FamEqn s a) where + loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c] + loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans + [loc a, loc tvs, loc b, loc c] + loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg _ ty) = loc ty + loc (HsArgPar sp) = sp + +instance HasLoc (HsDataDefn GhcRn) where + loc def@(HsDataDefn{}) = loc $ dd_cons def + -- Only used for data family instances, so we only need rhs + -- Most probably the rest will be unhelpful anyway + loc _ = noSrcSpan + +{- Note [Real DataCon Name] +The typechecker subtitutes the conLikeWrapId for the name, but we don't want +this showing up in the hieFile, so we replace the name in the Id with the +original datacon name +See also Note [Data Constructor Naming] +-} +class HasRealDataConName p where + getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) + +instance HasRealDataConName GhcRn where + getRealDataCon _ n = n +instance HasRealDataConName GhcTc where + getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = + L sp (setVarName var (conLikeName con)) + +-- | The main worker class +-- See Note [Updating HieAst for changes in the GHC AST] for more information +-- on how to add/modify instances for this. +class ToHie a where + toHie :: a -> HieM [HieAST Type] + +-- | Used to collect type info +class Data a => HasType a where + getTypeNode :: a -> HieM [HieAST Type] + +instance (ToHie a) => ToHie [a] where + toHie = concatMapM toHie + +instance (ToHie a) => ToHie (Bag a) where + toHie = toHie . bagToList + +instance (ToHie a) => ToHie (Maybe a) where + toHie = maybe (pure []) toHie + +instance ToHie (Context (Located NoExtField)) where + toHie _ = pure [] + +instance ToHie (TScoped NoExtField) where + toHie _ = pure [] + +instance ToHie (IEContext (Located ModuleName)) where + toHie (IEC c (L (RealSrcSpan span) mname)) = + pure $ [Node (NodeInfo S.empty [] idents) span []] + where details = mempty{identInfo = S.singleton (IEThing c)} + idents = M.singleton (Left mname) details + toHie _ = pure [] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') + -> do + m <- asks name_remapping + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right $ varName name) + (IdentifierDetails (Just $ varType name') + (S.singleton context))) + span + []] + _ -> pure [] + +instance ToHie (Context (Located Name)) where + toHie c = case c of + C context (L (RealSrcSpan span) name') -> do + m <- asks name_remapping + let name = case lookupNameEnv m name' of + Just var -> varName var + Nothing -> name' + pure + [Node + (NodeInfo S.empty [] $ + M.singleton (Right name) + (IdentifierDetails Nothing + (S.singleton context))) + span + []] + _ -> pure [] + +-- | Dummy instances - never called +instance ToHie (TScoped (LHsSigWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped (LHsWcType GhcTc)) where + toHie _ = pure [] +instance ToHie (SigContext (LSig GhcTc)) where + toHie _ = pure [] +instance ToHie (TScoped Type) where + toHie _ = pure [] + +instance HasType (LHsBind GhcRn) where + getTypeNode (L spn bind) = makeNode bind spn + +instance HasType (LHsBind GhcTc) where + getTypeNode (L spn bind) = case bind of + FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name) + _ -> makeNode bind spn + +instance HasType (Located (Pat GhcRn)) where + getTypeNode (L spn pat) = makeNode pat spn + +instance HasType (Located (Pat GhcTc)) where + getTypeNode (L spn opat) = makeTypeNode opat spn (hsPatType opat) + +instance HasType (LHsExpr GhcRn) where + getTypeNode (L spn e) = makeNode e spn + +-- | This instance tries to construct 'HieAST' nodes which include the type of +-- the expression. It is not yet possible to do this efficiently for all +-- expression forms, so we skip filling in the type for those inputs. +-- +-- 'HsApp', for example, doesn't have any type information available directly on +-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then +-- query the type of that. Yet both the desugaring call and the type query both +-- involve recursive calls to the function and argument! This is particularly +-- problematic when you realize that the HIE traversal will eventually visit +-- those nodes too and ask for their types again. +-- +-- Since the above is quite costly, we just skip cases where computing the +-- expression's type is going to be expensive. +-- +-- See #16233 +instance HasType (LHsExpr GhcTc) where + getTypeNode e@(L spn e') = lift $ + -- Some expression forms have their type immediately available + let tyOpt = case e' of + HsLit _ l -> Just (hsLitType l) + HsOverLit _ o -> Just (overLitType o) + + HsLam _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) + HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) + + ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitSum ty _ _ _ -> Just (mkSumTy ty) + HsDo ty _ _ -> Just ty + HsMultiIf ty _ -> Just ty + + _ -> Nothing + + in + case tyOpt of + Just t -> makeTypeNode e' spn t + Nothing + | skipDesugaring e' -> fallback + | otherwise -> do + hs_env <- Hsc $ \e w -> return (e,w) + (_,mbe) <- liftIO $ deSugarExpr hs_env e + maybe fallback (makeTypeNode e' spn . exprType) mbe + where + fallback = makeNode e' spn + + matchGroupType :: MatchGroupTc -> Type + matchGroupType (MatchGroupTc args res) = mkVisFunTys args res + + -- | Skip desugaring of these expressions for performance reasons. + -- + -- See impact on Haddock output (esp. missing type annotations or links) + -- before marking more things here as 'False'. See impact on Haddock + -- performance before marking more things as 'True'. + skipDesugaring :: HsExpr a -> Bool + skipDesugaring e = case e of + HsVar{} -> False + HsUnboundVar{} -> False + HsConLikeOut{} -> False + HsRecFld{} -> False + HsOverLabel{} -> False + HsIPVar{} -> False + HsWrap{} -> False + _ -> True + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a (LHsExpr a)) + , ToHie (LHsExpr a) + , ToHie (Located (PatSynBind a a)) + , HasType (LHsBind a) + , ModifyState (IdP a) + , Data (HsBind a) + ) => ToHie (BindContext (LHsBind a)) where + toHie (BC context scope b@(L span bind)) = + concatM $ getTypeNode b : case bind of + FunBind{fun_id = name, fun_matches = matches} -> + [ toHie $ C (ValBind context scope $ getRealSpan span) name + , toHie matches + ] + PatBind{pat_lhs = lhs, pat_rhs = rhs} -> + [ toHie $ PS (getRealSpan span) scope NoScope lhs + , toHie rhs + ] + VarBind{var_rhs = expr} -> + [ toHie expr + ] + AbsBinds{abs_exports = xs, abs_binds = binds} -> + [ local (modifyState xs) $ -- Note [Name Remapping] + toHie $ fmap (BC context scope) binds + ] + PatSynBind _ psb -> + [ toHie $ L span psb -- PatSynBinds only occur at the top level + ] + XHsBindsLR _ -> [] + +instance ( ToHie (LMatch a body) + ) => ToHie (MatchGroup a body) where + toHie mg = concatM $ case mg of + MG{ mg_alts = (L span alts) , mg_origin = FromSource } -> + [ pure $ locOnly span + , toHie alts + ] + MG{} -> [] + XMatchGroup _ -> [] + +instance ( ToHie (Context (Located (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (HsPatSynDir a) + ) => ToHie (Located (PatSynBind a a)) where + toHie (L sp psb) = concatM $ case psb of + PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} -> + [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var + , toHie $ toBind dets + , toHie $ PS Nothing lhsScope NoScope pat + , toHie dir + ] + where + lhsScope = combineScopes varScope detScope + varScope = mkLScope var + detScope = case dets of + (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args + (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b) + (RecCon r) -> foldr go NoScope r + go (RecordPatSynField a b) c = combineScopes c + $ combineScopes (mkLScope a) (mkLScope b) + detSpan = case detScope of + LocalScope a -> Just a + _ -> Nothing + toBind (PrefixCon args) = PrefixCon $ map (C Use) args + toBind (InfixCon a b) = InfixCon (C Use a) (C Use b) + toBind (RecCon r) = RecCon $ map (PSC detSpan) r + XPatSynBind _ -> [] + +instance ( ToHie (MatchGroup a (LHsExpr a)) + ) => ToHie (HsPatSynDir a) where + toHie dir = case dir of + ExplicitBidirectional mg -> toHie mg + _ -> pure [] + +instance ( a ~ GhcPass p + , ToHie body + , ToHie (HsMatchContext (NameOrRdrName (IdP a))) + , ToHie (PScoped (LPat a)) + , ToHie (GRHSs a body) + , Data (Match a body) + ) => ToHie (LMatch (GhcPass p) body) where + toHie (L span m ) = concatM $ makeNode m span : case m of + Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } -> + [ toHie mctx + , let rhsScope = mkScope $ grhss_span grhss + in toHie $ patScopes Nothing rhsScope NoScope pats + , toHie grhss + ] + XMatch _ -> [] + +instance ( ToHie (Context (Located a)) + ) => ToHie (HsMatchContext a) where + toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name + toHie (StmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( ToHie (HsMatchContext a) + ) => ToHie (HsStmtContext a) where + toHie (PatGuard a) = toHie a + toHie (ParStmtCtxt a) = toHie a + toHie (TransStmtCtxt a) = toHie a + toHie _ = pure [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , ToHie (RContext (HsRecFields a (PScoped (LPat a)))) + , ToHie (LHsExpr a) + , ToHie (TScoped (LHsSigWcType a)) + , ProtectSig a + , ToHie (TScoped (ProtectedSig a)) + , HasType (LPat a) + , Data (HsSplice a) + ) => ToHie (PScoped (Located (Pat (GhcPass p)))) where + toHie (PS rsp scope pscope lpat@(L ospan opat)) = + concatM $ getTypeNode lpat : case opat of + WildPat _ -> + [] + VarPat _ lname -> + [ toHie $ C (PatternBind scope pscope rsp) lname + ] + LazyPat _ p -> + [ toHie $ PS rsp scope pscope p + ] + AsPat _ lname pat -> + [ toHie $ C (PatternBind scope + (combineScopes (mkLScope pat) pscope) + rsp) + lname + , toHie $ PS rsp scope pscope pat + ] + ParPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + BangPat _ pat -> + [ toHie $ PS rsp scope pscope pat + ] + ListPat _ pats -> + [ toHie $ patScopes rsp scope pscope pats + ] + TuplePat _ pats _ -> + [ toHie $ patScopes rsp scope pscope pats + ] + SumPat _ pat _ _ -> + [ toHie $ PS rsp scope pscope pat + ] + ConPatIn c dets -> + [ toHie $ C Use c + , toHie $ contextify dets + ] + ConPatOut {pat_con = con, pat_args = dets}-> + [ toHie $ C Use $ fmap conLikeName con + , toHie $ contextify dets + ] + ViewPat _ expr pat -> + [ toHie expr + , toHie $ PS rsp scope pscope pat + ] + SplicePat _ sp -> + [ toHie $ L ospan sp + ] + LitPat _ _ -> + [] + NPat _ _ _ _ -> + [] + NPlusKPat _ n _ _ _ _ -> + [ toHie $ C (PatternBind scope pscope rsp) n + ] + SigPat _ pat sig -> + [ toHie $ PS rsp scope pscope pat + , let cscope = mkLScope pat in + toHie $ TS (ResolvedScopes [cscope, scope, pscope]) + (protectSig @a cscope sig) + -- See Note [Scoping Rules for SigPat] + ] + CoPat _ _ _ _ -> + [] + XPat _ -> [] + where + contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args + contextify (InfixCon a b) = InfixCon a' b' + where [a', b'] = patScopes rsp scope pscope [a,b] + contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r + contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a + where + go (RS fscope (L spn (HsRecField lbl pat pun))) = + L spn $ HsRecField lbl (PS rsp scope fscope pat) pun + scoped_fds = listScopes pscope fds + +instance ( ToHie body + , ToHie (LGRHS a body) + , ToHie (RScoped (LHsLocalBinds a)) + ) => ToHie (GRHSs a body) where + toHie grhs = concatM $ case grhs of + GRHSs _ grhss binds -> + [ toHie grhss + , toHie $ RS (mkScope $ grhss_span grhs) binds + ] + XGRHSs _ -> [] + +instance ( ToHie (Located body) + , ToHie (RScoped (GuardLStmt a)) + , Data (GRHS a (Located body)) + ) => ToHie (LGRHS a (Located body)) where + toHie (L span g) = concatM $ makeNode g span : case g of + GRHS _ guards body -> + [ toHie $ listScopes (mkLScope body) guards + , toHie body + ] + XGRHS _ -> [] + +instance ( a ~ GhcPass p + , ToHie (Context (Located (IdP a))) + , HasType (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (MatchGroup a (LHsExpr a)) + , ToHie (LGRHS a (LHsExpr a)) + , ToHie (RContext (HsRecordBinds a)) + , ToHie (RFContext (Located (AmbiguousFieldOcc a))) + , ToHie (ArithSeqInfo a) + , ToHie (LHsCmdTop a) + , ToHie (RScoped (GuardLStmt a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (TScoped (LHsWcType (NoGhcTc a))) + , ToHie (TScoped (LHsSigWcType (NoGhcTc a))) + , Data (HsExpr a) + , Data (HsSplice a) + , Data (HsTupArg a) + , Data (AmbiguousFieldOcc a) + , (HasRealDataConName a) + ) => ToHie (LHsExpr (GhcPass p)) where + toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of + HsVar _ (L _ var) -> + [ toHie $ C Use (L mspan var) + -- Patch up var location since typechecker removes it + ] + HsUnboundVar _ _ -> + [] + HsConLikeOut _ con -> + [ toHie $ C Use $ L mspan $ conLikeName con + ] + HsRecFld _ fld -> + [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) + ] + HsOverLabel _ _ _ -> [] + HsIPVar _ _ -> [] + HsOverLit _ _ -> [] + HsLit _ _ -> [] + HsLam _ mg -> + [ toHie mg + ] + HsLamCase _ mg -> + [ toHie mg + ] + HsApp _ a b -> + [ toHie a + , toHie b + ] + HsAppType _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes []) sig + ] + OpApp _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + NegApp _ a _ -> + [ toHie a + ] + HsPar _ a -> + [ toHie a + ] + SectionL _ a b -> + [ toHie a + , toHie b + ] + SectionR _ a b -> + [ toHie a + , toHie b + ] + ExplicitTuple _ args _ -> + [ toHie args + ] + ExplicitSum _ _ _ expr -> + [ toHie expr + ] + HsCase _ expr matches -> + [ toHie expr + , toHie matches + ] + HsIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsMultiIf _ grhss -> + [ toHie grhss + ] + HsLet _ binds expr -> + [ toHie $ RS (mkLScope expr) binds + , toHie expr + ] + HsDo _ _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + ExplicitList _ _ exprs -> + [ toHie exprs + ] + RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> + [ toHie $ C Use (getRealDataCon @a mrealcon name) + -- See Note [Real DataCon Name] + , toHie $ RC RecFieldAssign $ binds + ] + RecordUpd {rupd_expr = expr, rupd_flds = upds}-> + [ toHie expr + , toHie $ map (RC RecFieldAssign) upds + ] + ExprWithTySig _ expr sig -> + [ toHie expr + , toHie $ TS (ResolvedScopes [mkLScope expr]) sig + ] + ArithSeq _ _ info -> + [ toHie info + ] + HsPragE _ _ expr -> + [ toHie expr + ] + HsProc _ pat cmdtop -> + [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat + , toHie cmdtop + ] + HsStatic _ expr -> + [ toHie expr + ] + HsTick _ _ expr -> + [ toHie expr + ] + HsBinTick _ _ _ expr -> + [ toHie expr + ] + HsWrap _ _ a -> + [ toHie $ L mspan a + ] + HsBracket _ b -> + [ toHie b + ] + HsRnBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsTcBracketOut _ b p -> + [ toHie b + , toHie p + ] + HsSpliceE _ x -> + [ toHie $ L mspan x + ] + XExpr _ -> [] + +instance ( a ~ GhcPass p + , ToHie (LHsExpr a) + , Data (HsTupArg a) + ) => ToHie (LHsTupArg (GhcPass p)) where + toHie (L span arg) = concatM $ makeNode arg span : case arg of + Present _ expr -> + [ toHie expr + ] + Missing _ -> [] + XTupArg _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (LHsLocalBinds a)) + , ToHie (RScoped (ApplicativeArg a)) + , ToHie (Located body) + , Data (StmtLR a a (Located body)) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where + toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of + LastStmt _ body _ _ -> + [ toHie body + ] + BindStmt _ pat body _ _ -> + [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat + , toHie body + ] + ApplicativeStmt _ stmts _ -> + [ concatMapM (toHie . RS scope . snd) stmts + ] + BodyStmt _ body _ _ -> + [ toHie body + ] + LetStmt _ binds -> + [ toHie $ RS scope binds + ] + ParStmt _ parstmts _ _ -> + [ concatMapM (\(ParStmtBlock _ stmts _ _) -> + toHie $ listScopes NoScope stmts) + parstmts + ] + TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} -> + [ toHie $ listScopes scope stmts + , toHie using + , toHie by + ] + RecStmt {recS_stmts = stmts} -> + [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts + ] + XStmtLR _ -> [] + +instance ( ToHie (LHsExpr a) + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (LHsLocalBinds a)) where + toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of + EmptyLocalBinds _ -> [] + HsIPBinds _ _ -> [] + HsValBinds _ valBinds -> + [ toHie $ RS (combineScopes scope $ mkScope sp) + valBinds + ] + XHsLocalBindsLR _ -> [] + +instance ( ToHie (BindContext (LHsBind a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (XXValBindsLR a a)) + ) => ToHie (RScoped (HsValBindsLR a a)) where + toHie (RS sc v) = concatM $ case v of + ValBinds _ binds sigs -> + [ toHie $ fmap (BC RegularBind sc) binds + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + XValBindsLR x -> [ toHie $ RS sc x ] + +instance ToHie (RScoped (NHsValBindsLR GhcTc)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] +instance ToHie (RScoped (NHsValBindsLR GhcRn)) where + toHie (RS sc (NValBinds binds sigs)) = concatM $ + [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds) + , toHie $ fmap (SC (SI BindSig Nothing)) sigs + ] + +instance ( ToHie (RContext (LHsRecField a arg)) + ) => ToHie (RContext (HsRecFields a arg)) where + toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields + +instance ( ToHie (RFContext (Located label)) + , ToHie arg + , HasLoc arg + , Data label + , Data arg + ) => ToHie (RContext (LHsRecField' label arg)) where + toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of + HsRecField label expr _ -> + [ toHie $ RFC c (getRealSpan $ loc expr) label + , toHie expr + ] + +removeDefSrcSpan :: Name -> Name +removeDefSrcSpan n = setNameLoc n noSrcSpan + +instance ToHie (RFContext (LFieldOcc GhcRn)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc name _ -> + [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name) + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (LFieldOcc GhcTc)) where + toHie (RFC c rhs (L nspan f)) = concatM $ case f of + FieldOcc var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous name _ -> + [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name + ] + Ambiguous _name _ -> + [ ] + XAmbiguousFieldOcc _ -> [] + +instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where + toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of + Unambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + Ambiguous var _ -> + let var' = setVarName var (removeDefSrcSpan $ varName var) + in [ toHie $ C (RecField c rhs) (L nspan var') + ] + XAmbiguousFieldOcc _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (StmtLR a a (Located (HsExpr a))) + , Data (HsLocalBinds a) + ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where + toHie (RS sc (ApplicativeArgOne _ pat expr _ _)) = concatM + [ toHie $ PS Nothing sc NoScope pat + , toHie expr + ] + toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM + [ toHie $ listScopes NoScope stmts + , toHie $ PS Nothing sc NoScope pat + ] + toHie (RS _ (XApplicativeArg _)) = pure [] + +instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where + toHie (PrefixCon args) = toHie args + toHie (RecCon rec) = toHie rec + toHie (InfixCon a b) = concatM [ toHie a, toHie b] + +instance ( ToHie (LHsCmd a) + , Data (HsCmdTop a) + ) => ToHie (LHsCmdTop a) where + toHie (L span top) = concatM $ makeNode top span : case top of + HsCmdTop _ cmd -> + [ toHie cmd + ] + XCmdTop _ -> [] + +instance ( a ~ GhcPass p + , ToHie (PScoped (LPat a)) + , ToHie (BindContext (LHsBind a)) + , ToHie (LHsExpr a) + , ToHie (MatchGroup a (LHsCmd a)) + , ToHie (SigContext (LSig a)) + , ToHie (RScoped (HsValBindsLR a a)) + , Data (HsCmd a) + , Data (HsCmdTop a) + , Data (StmtLR a a (Located (HsCmd a))) + , Data (HsLocalBinds a) + , Data (StmtLR a a (Located (HsExpr a))) + ) => ToHie (LHsCmd (GhcPass p)) where + toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of + HsCmdArrApp _ a b _ _ -> + [ toHie a + , toHie b + ] + HsCmdArrForm _ a _ _ cmdtops -> + [ toHie a + , toHie cmdtops + ] + HsCmdApp _ a b -> + [ toHie a + , toHie b + ] + HsCmdLam _ mg -> + [ toHie mg + ] + HsCmdPar _ a -> + [ toHie a + ] + HsCmdCase _ expr alts -> + [ toHie expr + , toHie alts + ] + HsCmdIf _ _ a b c -> + [ toHie a + , toHie b + , toHie c + ] + HsCmdLet _ binds cmd' -> + [ toHie $ RS (mkLScope cmd') binds + , toHie cmd' + ] + HsCmdDo _ (L ispan stmts) -> + [ pure $ locOnly ispan + , toHie $ listScopes NoScope stmts + ] + HsCmdWrap _ _ _ -> [] + XCmd _ -> [] + +instance ToHie (TyClGroup GhcRn) where + toHie TyClGroup{ group_tyclds = classes + , group_roles = roles + , group_kisigs = sigs + , group_instds = instances } = + concatM + [ toHie classes + , toHie sigs + , toHie roles + , toHie instances + ] + toHie (XTyClGroup _) = pure [] + +instance ToHie (LTyClDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamDecl {tcdFam = fdecl} -> + [ toHie (L span fdecl) + ] + SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} -> + [ toHie $ C (Decl SynDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars + , toHie typ + ] + DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} -> + [ toHie $ C (Decl DataDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars + , toHie defn + ] + where + quant_scope = mkLScope $ dd_ctxt defn + rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc + sig_sc = maybe NoScope mkLScope $ dd_kindSig defn + con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn + deriv_sc = mkLScope $ dd_derivs defn + ClassDecl { tcdCtxt = context + , tcdLName = name + , tcdTyVars = vars + , tcdFDs = deps + , tcdSigs = sigs + , tcdMeths = meths + , tcdATs = typs + , tcdATDefs = deftyps + } -> + [ toHie $ C (Decl ClassDec $ getRealSpan span) name + , toHie context + , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars + , toHie deps + , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs + , toHie $ fmap (BC InstanceBind ModuleScope) meths + , toHie typs + , concatMapM (pure . locOnly . getLoc) deftyps + , toHie deftyps + ] + where + context_scope = mkLScope context + rhs_scope = foldl1' combineScopes $ map mkScope + [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] + XTyClDecl _ -> [] + +instance ToHie (LFamilyDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + FamilyDecl _ info name vars _ sig inj -> + [ toHie $ C (Decl FamDec $ getRealSpan span) name + , toHie $ TS (ResolvedScopes [rhsSpan]) vars + , toHie info + , toHie $ RS injSpan sig + , toHie inj + ] + where + rhsSpan = sigSpan `combineScopes` injSpan + sigSpan = mkScope $ getLoc sig + injSpan = maybe NoScope (mkScope . getLoc) inj + XFamilyDecl _ -> [] + +instance ToHie (FamilyInfo GhcRn) where + toHie (ClosedTypeFamily (Just eqns)) = concatM $ + [ concatMapM (pure . locOnly . getLoc) eqns + , toHie $ map go eqns + ] + where + go (L l ib) = TS (ResolvedScopes [mkScope l]) ib + toHie _ = pure [] + +instance ToHie (RScoped (LFamilyResultSig GhcRn)) where + toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of + NoSig _ -> + [] + KindSig _ k -> + [ toHie k + ] + TyVarSig _ bndr -> + [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr + ] + XFamilyResultSig _ -> [] + +instance ToHie (Located (FunDep (Located Name))) where + toHie (L span fd@(lhs, rhs)) = concatM $ + [ makeNode fd span + , toHie $ map (C Use) lhs + , toHie $ map (C Use) rhs + ] + +instance (ToHie rhs, HasLoc rhs) + => ToHie (TScoped (FamEqn GhcRn rhs)) where + toHie (TS _ f) = toHie f + +instance (ToHie rhs, HasLoc rhs) + => ToHie (FamEqn GhcRn rhs) where + toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $ + [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie pats + , toHie rhs + ] + where scope = combineScopes patsScope rhsScope + patsScope = mkScope (loc pats) + rhsScope = mkScope (loc rhs) + toHie (XFamEqn _) = pure [] + +instance ToHie (LInjectivityAnn GhcRn) where + toHie (L span ann) = concatM $ makeNode ann span : case ann of + InjectivityAnn lhs rhs -> + [ toHie $ C Use lhs + , toHie $ map (C Use) rhs + ] + +instance ToHie (HsDataDefn GhcRn) where + toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM + [ toHie ctx + , toHie mkind + , toHie cons + , toHie derivs + ] + toHie (XHsDataDefn _) = pure [] + +instance ToHie (HsDeriving GhcRn) where + toHie (L span clauses) = concatM + [ pure $ locOnly span + , toHie clauses + ] + +instance ToHie (LHsDerivingClause GhcRn) where + toHie (L span cl) = concatM $ makeNode cl span : case cl of + HsDerivingClause _ strat (L ispan tys) -> + [ toHie strat + , pure $ locOnly ispan + , toHie $ map (TS (ResolvedScopes [])) tys + ] + XHsDerivingClause _ -> [] + +instance ToHie (Located (DerivStrategy GhcRn)) where + toHie (L span strat) = concatM $ makeNode strat span : case strat of + StockStrategy -> [] + AnyclassStrategy -> [] + NewtypeStrategy -> [] + ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ] + +instance ToHie (Located OverlapMode) where + toHie (L span _) = pure $ locOnly span + +instance ToHie (LConDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ConDeclGADT { con_names = names, con_qvars = qvars + , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names + , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars + , toHie ctx + , toHie args + , toHie typ + ] + where + rhsScope = combineScopes argsScope tyScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope args + tyScope = mkLScope typ + ConDeclH98 { con_name = name, con_ex_tvs = qvars + , con_mb_cxt = ctx, con_args = dets } -> + [ toHie $ C (Decl ConDec $ getRealSpan span) name + , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars + , toHie ctx + , toHie dets + ] + where + rhsScope = combineScopes ctxScope argsScope + ctxScope = maybe NoScope mkLScope ctx + argsScope = condecl_scope dets + XConDecl _ -> [] + where condecl_scope args = case args of + PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs + InfixCon a b -> combineScopes (mkLScope a) (mkLScope b) + RecCon x -> mkLScope x + +instance ToHie (Located [LConDeclField GhcRn]) where + toHie (L span decls) = concatM $ + [ pure $ locOnly span + , toHie decls + ] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where + toHie (TS sc (HsIB ibrn a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsImplicitBndrs _)) = pure [] + +instance ( HasLoc thing + , ToHie (TScoped thing) + ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where + toHie (TS sc (HsWC names a)) = concatM $ + [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names + , toHie $ TS sc a + ] + where span = loc a + toHie (TS _ (XHsWildCardBndrs _)) = pure [] + +instance ToHie (LStandaloneKindSig GhcRn) where + toHie (L sp sig) = concatM [makeNode sig sp, toHie sig] + +instance ToHie (StandaloneKindSig GhcRn) where + toHie sig = concatM $ case sig of + StandaloneKindSig _ name typ -> + [ toHie $ C TyDecl name + , toHie $ TS (ResolvedScopes []) typ + ] + XStandaloneKindSig _ -> [] + +instance ToHie (SigContext (LSig GhcRn)) where + toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of + TypeSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + PatSynSig _ names typ -> + [ toHie $ map (C TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ + ] + ClassOpSig _ _ names typ -> + [ case styp of + ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names + _ -> toHie $ map (C $ TyDecl) names + , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ + ] + IdSig _ _ -> [] + FixSig _ fsig -> + [ toHie $ L sp fsig + ] + InlineSig _ name _ -> + [ toHie $ (C Use) name + ] + SpecSig _ name typs _ -> + [ toHie $ (C Use) name + , toHie $ map (TS (ResolvedScopes [])) typs + ] + SpecInstSig _ _ typ -> + [ toHie $ TS (ResolvedScopes []) typ + ] + MinimalSig _ _ form -> + [ toHie form + ] + SCCFunSig _ _ name mtxt -> + [ toHie $ (C Use) name + , pure $ maybe [] (locOnly . getLoc) mtxt + ] + CompleteMatchSig _ _ (L ispan names) typ -> + [ pure $ locOnly ispan + , toHie $ map (C Use) names + , toHie $ fmap (C Use) typ + ] + XSig _ -> [] + +instance ToHie (LHsType GhcRn) where + toHie x = toHie $ TS (ResolvedScopes []) x + +instance ToHie (TScoped (LHsType GhcRn)) where + toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of + HsForAllTy _ _ bndrs body -> + [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs + , toHie body + ] + HsQualTy _ ctx body -> + [ toHie ctx + , toHie body + ] + HsTyVar _ _ var -> + [ toHie $ C Use var + ] + HsAppTy _ a b -> + [ toHie a + , toHie b + ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] + HsFunTy _ a b -> + [ toHie a + , toHie b + ] + HsListTy _ a -> + [ toHie a + ] + HsTupleTy _ _ tys -> + [ toHie tys + ] + HsSumTy _ tys -> + [ toHie tys + ] + HsOpTy _ a op b -> + [ toHie a + , toHie $ C Use op + , toHie b + ] + HsParTy _ a -> + [ toHie a + ] + HsIParamTy _ ip ty -> + [ toHie ip + , toHie ty + ] + HsKindSig _ a b -> + [ toHie a + , toHie b + ] + HsSpliceTy _ a -> + [ toHie $ L span a + ] + HsDocTy _ a _ -> + [ toHie a + ] + HsBangTy _ _ ty -> + [ toHie ty + ] + HsRecTy _ fields -> + [ toHie fields + ] + HsExplicitListTy _ _ tys -> + [ toHie tys + ] + HsExplicitTupleTy _ tys -> + [ toHie tys + ] + HsTyLit _ _ -> [] + HsWildCardTy _ -> [] + HsStarTy _ _ -> [] + XHsType _ -> [] + +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg _ ty) = toHie ty + toHie (HsArgPar sp) = pure $ locOnly sp + +instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where + toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + UserTyVar _ var -> + [ toHie $ C (TyVarBind sc tsc) var + ] + KindedTyVar _ var kind -> + [ toHie $ C (TyVarBind sc tsc) var + , toHie kind + ] + XTyVarBndr _ -> [] + +instance ToHie (TScoped (LHsQTyVars GhcRn)) where + toHie (TS sc (HsQTvs implicits vars)) = concatM $ + [ pure $ bindingsOnly bindings + , toHie $ tvScopes sc NoScope vars + ] + where + varLoc = loc vars + bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits + toHie (TS _ (XLHsQTyVars _)) = pure [] + +instance ToHie (LHsContext GhcRn) where + toHie (L span tys) = concatM $ + [ pure $ locOnly span + , toHie tys + ] + +instance ToHie (LConDeclField GhcRn) where + toHie (L span field) = concatM $ makeNode field span : case field of + ConDeclField _ fields typ _ -> + [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields + , toHie typ + ] + XConDeclField _ -> [] + +instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where + toHie (From expr) = toHie expr + toHie (FromThen a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromTo a b) = concatM $ + [ toHie a + , toHie b + ] + toHie (FromThenTo a b c) = concatM $ + [ toHie a + , toHie b + , toHie c + ] + +instance ToHie (LSpliceDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + SpliceDecl _ splice _ -> + [ toHie splice + ] + XSpliceDecl _ -> [] + +instance ToHie (HsBracket a) where + toHie _ = pure [] + +instance ToHie PendingRnSplice where + toHie _ = pure [] + +instance ToHie PendingTcSplice where + toHie _ = pure [] + +instance ToHie (LBooleanFormula (Located Name)) where + toHie (L span form) = concatM $ makeNode form span : case form of + Var a -> + [ toHie $ C Use a + ] + And forms -> + [ toHie forms + ] + Or forms -> + [ toHie forms + ] + Parens f -> + [ toHie f + ] + +instance ToHie (Located HsIPName) where + toHie (L span e) = makeNode e span + +instance ( ToHie (LHsExpr a) + , Data (HsSplice a) + ) => ToHie (Located (HsSplice a)) where + toHie (L span sp) = concatM $ makeNode sp span : case sp of + HsTypedSplice _ _ _ expr -> + [ toHie expr + ] + HsUntypedSplice _ _ _ expr -> + [ toHie expr + ] + HsQuasiQuote _ _ _ ispan _ -> + [ pure $ locOnly ispan + ] + HsSpliced _ _ _ -> + [] + HsSplicedT _ -> + [] + XSplice _ -> [] + +instance ToHie (LRoleAnnotDecl GhcRn) where + toHie (L span annot) = concatM $ makeNode annot span : case annot of + RoleAnnotDecl _ var roles -> + [ toHie $ C Use var + , concatMapM (pure . locOnly . getLoc) roles + ] + XRoleAnnotDecl _ -> [] + +instance ToHie (LInstDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ClsInstD _ d -> + [ toHie $ L span d + ] + DataFamInstD _ d -> + [ toHie $ L span d + ] + TyFamInstD _ d -> + [ toHie $ L span d + ] + XInstDecl _ -> [] + +instance ToHie (LClsInstDecl GhcRn) where + toHie (L span decl) = concatM + [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl + , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl + , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl + , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl + , toHie $ cid_tyfam_insts decl + , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl + , toHie $ cid_datafam_insts decl + , toHie $ cid_overlap_mode decl + ] + +instance ToHie (LDataFamInstDecl GhcRn) where + toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (LTyFamInstDecl GhcRn) where + toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d + +instance ToHie (Context a) + => ToHie (PatSynFieldContext (RecordPatSynField a)) where + toHie (PSC sp (RecordPatSynField a b)) = concatM $ + [ toHie $ C (RecField RecFieldDecl sp) a + , toHie $ C Use b + ] + +instance ToHie (LDerivDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DerivDecl _ typ strat overlap -> + [ toHie $ TS (ResolvedScopes []) typ + , toHie strat + , toHie overlap + ] + XDerivDecl _ -> [] + +instance ToHie (LFixitySig GhcRn) where + toHie (L span sig) = concatM $ makeNode sig span : case sig of + FixitySig _ vars _ -> + [ toHie $ map (C Use) vars + ] + XFixitySig _ -> [] + +instance ToHie (LDefaultDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + DefaultDecl _ typs -> + [ toHie typs + ] + XDefaultDecl _ -> [] + +instance ToHie (LForeignDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} -> + [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name + , toHie $ TS (ResolvedScopes []) sig + , toHie fi + ] + ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} -> + [ toHie $ C Use name + , toHie $ TS (ResolvedScopes []) sig + , toHie fe + ] + XForeignDecl _ -> [] + +instance ToHie ForeignImport where + toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $ + [ locOnly a + , locOnly b + , locOnly c + ] + +instance ToHie ForeignExport where + toHie (CExport (L a _) (L b _)) = pure $ concat $ + [ locOnly a + , locOnly b + ] + +instance ToHie (LWarnDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warnings _ _ warnings -> + [ toHie warnings + ] + XWarnDecls _ -> [] + +instance ToHie (LWarnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + Warning _ vars _ -> + [ toHie $ map (C Use) vars + ] + XWarnDecl _ -> [] + +instance ToHie (LAnnDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsAnnotation _ _ prov expr -> + [ toHie prov + , toHie expr + ] + XAnnDecl _ -> [] + +instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where + toHie (ValueAnnProvenance a) = toHie $ C Use a + toHie (TypeAnnProvenance a) = toHie $ C Use a + toHie ModuleAnnProvenance = pure [] + +instance ToHie (LRuleDecls GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + HsRules _ _ rules -> + [ toHie rules + ] + XRuleDecls _ -> [] + +instance ToHie (LRuleDecl GhcRn) where + toHie (L _ (XRuleDecl _)) = pure [] + toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM + [ makeNode r span + , pure $ locOnly $ getLoc rname + , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs + , toHie $ map (RS $ mkScope span) bndrs + , toHie exprA + , toHie exprB + ] + where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc + bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs) + exprA_sc = mkLScope exprA + exprB_sc = mkLScope exprB + +instance ToHie (RScoped (LRuleBndr GhcRn)) where + toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of + RuleBndr _ var -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + ] + RuleBndrSig _ var typ -> + [ toHie $ C (ValBind RegularBind sc Nothing) var + , toHie $ TS (ResolvedScopes [sc]) typ + ] + XRuleBndr _ -> [] + +instance ToHie (LImportDecl GhcRn) where + toHie (L span decl) = concatM $ makeNode decl span : case decl of + ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } -> + [ toHie $ IEC Import name + , toHie $ fmap (IEC ImportAs) as + , maybe (pure []) goIE hidden + ] + XImportDecl _ -> [] + where + goIE (hiding, (L sp liens)) = concatM $ + [ pure $ locOnly sp + , toHie $ map (IEC c) liens + ] + where + c = if hiding then ImportHiding else Import + +instance ToHie (IEContext (LIE GhcRn)) where + toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of + IEVar _ n -> + [ toHie $ IEC c n + ] + IEThingAbs _ n -> + [ toHie $ IEC c n + ] + IEThingAll _ n -> + [ toHie $ IEC c n + ] + IEThingWith _ n _ ns flds -> + [ toHie $ IEC c n + , toHie $ map (IEC c) ns + , toHie $ map (IEC c) flds + ] + IEModuleContents _ n -> + [ toHie $ IEC c n + ] + IEGroup _ _ _ -> [] + IEDoc _ _ -> [] + IEDocNamed _ _ -> [] + XIE _ -> [] + +instance ToHie (IEContext (LIEWrappedName Name)) where + toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of + IEName n -> + [ toHie $ C (IEThing c) n + ] + IEPattern p -> + [ toHie $ C (IEThing c) p + ] + IEType n -> + [ toHie $ C (IEThing c) n + ] + +instance ToHie (IEContext (Located (FieldLbl Name))) where + toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of + FieldLabel _ _ n -> + [ toHie $ C (IEThing c) $ L span n + ] diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs new file mode 100644 index 0000000000..91fe256cc8 --- /dev/null +++ b/compiler/GHC/Iface/Ext/Binary.hs @@ -0,0 +1,403 @@ +{- +Binary serialization for .hie files. +-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Iface.Ext.Binary + ( readHieFile + , readHieFileWithVersion + , HieHeader + , writeHieFile + , HieName(..) + , toHieName + , HieFileResult(..) + , hieMagic + , hieNameOcc + ) +where + +import GHC.Settings ( maybeRead ) + +import Config ( cProjectVersion ) +import GhcPrelude +import Binary +import GHC.Iface.Binary ( getDictFastString ) +import FastMutInt +import FastString ( FastString ) +import Module ( Module ) +import Name +import NameCache +import Outputable +import PrelInfo +import SrcLoc +import UniqSupply ( takeUniqFromSupply ) +import Unique +import UniqFM + +import qualified Data.Array as A +import Data.IORef +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import Data.List ( mapAccumR ) +import Data.Word ( Word8, Word32 ) +import Control.Monad ( replicateM, when ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( takeDirectory ) + +import GHC.Iface.Ext.Types + +-- | `Name`'s get converted into `HieName`'s before being written into @.hie@ +-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between +-- these two types. +data HieName + = ExternalName !Module !OccName !SrcSpan + | LocalName !OccName !SrcSpan + | KnownKeyName !Unique + deriving (Eq) + +instance Ord HieName where + compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f) + compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d) + compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b + -- Not actually non deterministic as it is a KnownKey + compare ExternalName{} _ = LT + compare LocalName{} ExternalName{} = GT + compare LocalName{} _ = LT + compare KnownKeyName{} _ = GT + +instance Outputable HieName where + ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp + ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp + ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u + +hieNameOcc :: HieName -> OccName +hieNameOcc (ExternalName _ occ _) = occ +hieNameOcc (LocalName occ _) = occ +hieNameOcc (KnownKeyName u) = + case lookupKnownKeyName u of + Just n -> nameOccName n + Nothing -> pprPanic "hieNameOcc:unknown known-key unique" + (ppr (unpkUnique u)) + + +data HieSymbolTable = HieSymbolTable + { hie_symtab_next :: !FastMutInt + , hie_symtab_map :: !(IORef (UniqFM (Int, HieName))) + } + +data HieDictionary = HieDictionary + { hie_dict_next :: !FastMutInt -- The next index to use + , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString + } + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + +-- | The header for HIE files - Capital ASCII letters "HIE". +hieMagic :: [Word8] +hieMagic = [72,73,69] + +hieMagicLen :: Int +hieMagicLen = length hieMagic + +ghcVersion :: ByteString +ghcVersion = BSC.pack cProjectVersion + +putBinLine :: BinHandle -> ByteString -> IO () +putBinLine bh xs = do + mapM_ (putByte bh) $ BS.unpack xs + putByte bh 10 -- newline char + +-- | Write a `HieFile` to the given `FilePath`, with a proper header and +-- symbol tables for `Name`s and `FastString`s +writeHieFile :: FilePath -> HieFile -> IO () +writeHieFile hie_file_path hiefile = do + bh0 <- openBinMem initBinMemSize + + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ (putByte bh0) hieMagic + putBinLine bh0 $ BSC.pack $ show hieVersion + putBinLine bh0 $ ghcVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some initial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let hie_symtab = HieSymbolTable { + hie_symtab_next = symtab_next, + hie_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let hie_dict = HieDictionary { + hie_dict_next = dict_next_ref, + hie_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName hie_symtab) + (putName hie_symtab) + (putFastString hie_dict) + put_ bh hiefile + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the front of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + createDirectoryIfMissing True (takeDirectory hie_file_path) + writeBinMem bh hie_file_path + return () + +data HieFileResult + = HieFileResult + { hie_file_result_version :: Integer + , hie_file_result_ghc_version :: ByteString + , hie_file_result :: HieFile + } + +type HieHeader = (Integer, ByteString) + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. Allows you to specify +-- which versions of hieFile to attempt to read. +-- `Left` case returns the failing header versions. +readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache)) +readHieFileWithVersion readVersion nc file = do + bh0 <- readBinMem file + + (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + + if readVersion (hieVersion, ghcVersion) + then do + (hieFile, nc') <- readHieFileContents bh0 nc + return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc') + else return $ Left (hieVersion, ghcVersion) + + +-- | Read a `HieFile` from a `FilePath`. Can use +-- an existing `NameCache`. +readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache) +readHieFile nc file = do + + bh0 <- readBinMem file + + (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + (hieFile, nc') <- readHieFileContents bh0 nc + return $ (HieFileResult hieVersion ghcVersion hieFile, nc') + +readBinLine :: BinHandle -> IO ByteString +readBinLine bh = BS.pack . reverse <$> loop [] + where + loop acc = do + char <- get bh :: IO Word8 + if char == 10 -- ASCII newline '\n' + then return acc + else loop (char : acc) + +readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader +readHieFileHeader file bh0 = do + -- Read the header + magic <- replicateM hieMagicLen (get bh0) + version <- BSC.unpack <$> readBinLine bh0 + case maybeRead version of + Nothing -> + panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" + , show version + ] + Just readHieVersion -> do + ghcVersion <- readBinLine bh0 + + -- Check if the header is valid + when (magic /= hieMagic) $ + panic $ unwords ["readHieFileHeader: headers don't match for file:" + , file + , "Expected" + , show hieMagic + , "but got", show magic + ] + return (readHieVersion, ghcVersion) + +readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache) +readHieFileContents bh0 nc = do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + (bh1, nc') <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + (nc', symtab) <- get_symbol_table bh1 + let bh1' = setUserData bh1 + $ newReadState (getSymTabName symtab) + (getDictFastString dict) + return (bh1', nc') + + -- load the actual data + hiefile <- get bh1 + return (hiefile, nc') + where + get_dictionary bin_handle = do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 = do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + (nc', symtab) <- getSymbolTable bh1 nc + seekBin bh1 data_p' + return (nc', symtab) + +putFastString :: HieDictionary -> BinHandle -> FastString -> IO () +putFastString HieDictionary { hie_dict_next = j_r, + hie_dict_map = out_r} bh f + = do + out <- readIORef out_r + let unique = getUnique f + case lookupUFM out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out unique (j, f) + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) + mapM_ (putHieName bh) names + +getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable) +getSymbolTable bh namecache = do + sz <- get bh + od_names <- replicateM sz (getHieName bh) + let arr = A.listArray (0,sz-1) names + (namecache', names) = mapAccumR fromHieName namecache od_names + return (namecache', arr) + +getSymTabName :: SymbolTable -> BinHandle -> IO Name +getSymTabName st bh = do + i :: Word32 <- get bh + return $ st A.! (fromIntegral i) + +putName :: HieSymbolTable -> BinHandle -> Name -> IO () +putName (HieSymbolTable next ref) bh name = do + symmap <- readIORef ref + case lookupUFM symmap name of + Just (off, ExternalName mod occ (UnhelpfulSpan _)) + | isGoodSrcSpan (nameSrcSpan name) -> do + let hieName = ExternalName mod occ (nameSrcSpan name) + writeIORef ref $! addToUFM symmap name (off, hieName) + put_ bh (fromIntegral off :: Word32) + Just (off, LocalName _occ span) + | notLocal (toHieName name) || nameSrcSpan name /= span -> do + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + Just (off, _) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt next + writeFastMutInt next (off+1) + writeIORef ref $! addToUFM symmap name (off, toHieName name) + put_ bh (fromIntegral off :: Word32) + + where + notLocal :: HieName -> Bool + notLocal LocalName{} = False + notLocal _ = True + + +-- ** Converting to and from `HieName`'s + +toHieName :: Name -> HieName +toHieName name + | isKnownKeyName name = KnownKeyName (nameUnique name) + | isExternalName name = ExternalName (nameModule name) + (nameOccName name) + (nameSrcSpan name) + | otherwise = LocalName (nameOccName name) (nameSrcSpan name) + +fromHieName :: NameCache -> HieName -> (NameCache, Name) +fromHieName nc (ExternalName mod occ span) = + let cache = nsNames nc + in case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkExternalName uniq mod occ span + new_cache = extendNameCache cache mod occ name + in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) +fromHieName nc (LocalName occ span) = + let (uniq, us) = takeUniqFromSupply (nsUniqs nc) + name = mkInternalName uniq occ span + in ( nc{ nsUniqs = us }, name ) +fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of + Nothing -> pprPanic "fromHieName:unknown known-key unique" + (ppr (unpkUnique u)) + Just n -> (nc, n) + +-- ** Reading and writing `HieName`'s + +putHieName :: BinHandle -> HieName -> IO () +putHieName bh (ExternalName mod occ span) = do + putByte bh 0 + put_ bh (mod, occ, span) +putHieName bh (LocalName occName span) = do + putByte bh 1 + put_ bh (occName, span) +putHieName bh (KnownKeyName uniq) = do + putByte bh 2 + put_ bh $ unpkUnique uniq + +getHieName :: BinHandle -> IO HieName +getHieName bh = do + t <- getByte bh + case t of + 0 -> do + (modu, occ, span) <- get bh + return $ ExternalName modu occ span + 1 -> do + (occ, span) <- get bh + return $ LocalName occ span + 2 -> do + (c,i) <- get bh + return $ KnownKeyName $ mkUnique c i + _ -> panic "GHC.Iface.Ext.Binary.getHieName: invalid tag" diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs new file mode 100644 index 0000000000..25cc940834 --- /dev/null +++ b/compiler/GHC/Iface/Ext/Debug.hs @@ -0,0 +1,172 @@ +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHC.Iface.Ext.Debug where + +import GhcPrelude + +import SrcLoc +import Module +import FastString +import Outputable + +import GHC.Iface.Ext.Types +import GHC.Iface.Ext.Binary +import GHC.Iface.Ext.Utils +import Name + +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Function ( on ) +import Data.List ( sortOn ) +import Data.Foldable ( toList ) + +ppHies :: Outputable a => (HieASTs a) -> SDoc +ppHies (HieASTs asts) = M.foldrWithKey go "" asts + where + go k a rest = vcat $ + [ "File: " <> ppr k + , ppHie a + , rest + ] + +ppHie :: Outputable a => HieAST a -> SDoc +ppHie = go 0 + where + go n (Node inf sp children) = hang header n rest + where + rest = vcat $ map (go (n+2)) children + header = hsep + [ "Node" + , ppr sp + , ppInfo inf + ] + +ppInfo :: Outputable a => NodeInfo a -> SDoc +ppInfo ni = hsep + [ ppr $ toList $ nodeAnnotations ni + , ppr $ nodeType ni + , ppr $ M.toList $ nodeIdentifiers ni + ] + +type Diff a = a -> a -> [SDoc] + +diffFile :: Diff HieFile +diffFile = diffAsts eqDiff `on` (getAsts . hie_asts) + +diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a)) +diffAsts f = diffList (diffAst f) `on` M.elems + +diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a) +diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) = + infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2 + where + spanDiff + | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]] + | otherwise = [] + infoDiff' + = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2 + ++ (diffList diffType `on` nodeType) info1 info2 + ++ (diffIdents `on` nodeIdentifiers) info1 info2 + infoDiff = case infoDiff' of + [] -> [] + xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1) + , "and", ppr (nodeIdentifiers info2,span2) + , "While comparing" + , ppr (normalizeIdents $ nodeIdentifiers info1), "and" + , ppr (normalizeIdents $ nodeIdentifiers info2) + ] + ] + + diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b + diffIdent (a,b) (c,d) = diffName a c + ++ eqDiff b d + diffName (Right a) (Right b) = case (a,b) of + (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o') + (LocalName o _, ExternalName _ o' _) -> eqDiff o o' + _ -> eqDiff a b + diffName a b = eqDiff a b + +type DiffIdent = Either ModuleName HieName + +normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)] +normalizeIdents = sortOn go . map (first toHieName) . M.toList + where + first f (a,b) = (fmap f a, b) + go (a,b) = (hieNameOcc <$> a,identInfo b,identType b) + +diffList :: Diff a -> Diff [a] +diffList f xs ys + | length xs == length ys = concat $ zipWith f xs ys + | otherwise = ["length of lists doesn't match"] + +eqDiff :: (Outputable a, Eq a) => Diff a +eqDiff a b + | a == b = [] + | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]] + +validAst :: HieAST a -> Either SDoc () +validAst (Node _ span children) = do + checkContainment children + checkSorted children + mapM_ validAst children + where + checkSorted [] = return () + checkSorted [_] = return () + checkSorted (x:y:xs) + | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs) + | otherwise = Left $ hsep + [ ppr $ nodeSpan x + , "is not to the left of" + , ppr $ nodeSpan y + ] + checkContainment [] = return () + checkContainment (x:xs) + | span `containsSpan` (nodeSpan x) = checkContainment xs + | otherwise = Left $ hsep + [ ppr $ span + , "does not contain" + , ppr $ nodeSpan x + ] + +-- | Look for any identifiers which occur outside of their supposed scopes. +-- Returns a list of error messages. +validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc] +validateScopes mod asts = validScopes + where + refMap = generateReferencesMap asts + -- We use a refmap for most of the computation + + -- Check if all the names occur in their calculated scopes + validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap + valid (Left _) _ = [] + valid (Right n) refs = concatMap inScope refs + where + mapRef = foldMap getScopeFromContext . identInfo . snd + scopes = case foldMap mapRef refs of + Just xs -> xs + Nothing -> [] + inScope (sp, dets) + | (definedInAsts asts n) + && any isOccurrence (identInfo dets) + -- We validate scopes for names which are defined locally, and occur + -- in this span + = case scopes of + [] | (nameIsLocalOrFrom mod n + && not (isDerivedOccName $ nameOccName n)) + -- If we don't get any scopes for a local name then its an error. + -- We can ignore derived names. + -> return $ hsep $ + [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp + , "Doesn't have a calculated scope: ", ppr scopes] + | otherwise -> [] + _ -> if any (`scopeContainsSpan` sp) scopes + then [] + else return $ hsep $ + [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp + , "doesn't occur in calculated scope", ppr scopes] + | otherwise = [] diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs new file mode 100644 index 0000000000..e56864bc04 --- /dev/null +++ b/compiler/GHC/Iface/Ext/Types.hs @@ -0,0 +1,509 @@ +{- +Types for the .hie file format are defined here. + +For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files +-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module GHC.Iface.Ext.Types where + +import GhcPrelude + +import Config +import Binary +import FastString ( FastString ) +import GHC.Iface.Type +import Module ( ModuleName, Module ) +import Name ( Name ) +import Outputable hiding ( (<>) ) +import SrcLoc ( RealSrcSpan ) +import Avail + +import qualified Data.Array as A +import qualified Data.Map as M +import qualified Data.Set as S +import Data.ByteString ( ByteString ) +import Data.Data ( Typeable, Data ) +import Data.Semigroup ( Semigroup(..) ) +import Data.Word ( Word8 ) +import Control.Applicative ( (<|>) ) + +type Span = RealSrcSpan + +-- | Current version of @.hie@ files +hieVersion :: Integer +hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +{- | +GHC builds up a wealth of information about Haskell source as it compiles it. +@.hie@ files are a way of persisting some of this information to disk so that +external tools that need to work with haskell source don't need to parse, +typecheck, and rename all over again. These files contain: + + * a simplified AST + + * nodes are annotated with source positions and types + * identifiers are annotated with scope information + + * the raw bytes of the initial Haskell source + +Besides saving compilation cycles, @.hie@ files also offer a more stable +interface than the GHC API. +-} +data HieFile = HieFile + { hie_hs_file :: FilePath + -- ^ Initial Haskell source file path + + , hie_module :: Module + -- ^ The module this HIE file is for + + , hie_types :: A.Array TypeIndex HieTypeFlat + -- ^ Types referenced in the 'hie_asts'. + -- + -- See Note [Efficient serialization of redundant type info] + + , hie_asts :: HieASTs TypeIndex + -- ^ Type-annotated abstract syntax trees + + , hie_exports :: [AvailInfo] + -- ^ The names that this module exports + + , hie_hs_src :: ByteString + -- ^ Raw bytes of the initial Haskell source + } +instance Binary HieFile where + put_ bh hf = do + put_ bh $ hie_hs_file hf + put_ bh $ hie_module hf + put_ bh $ hie_types hf + put_ bh $ hie_asts hf + put_ bh $ hie_exports hf + put_ bh $ hie_hs_src hf + + get bh = HieFile + <$> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + <*> get bh + + +{- +Note [Efficient serialization of redundant type info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The type information in .hie files is highly repetitive and redundant. For +example, consider the expression + + const True 'a' + +There is a lot of shared structure between the types of subterms: + + * const True 'a' :: Bool + * const True :: Char -> Bool + * const :: Bool -> Char -> Bool + +Since all 3 of these types need to be stored in the .hie file, it is worth +making an effort to deduplicate this shared structure. The trick is to define +a new data type that is a flattened version of 'Type': + + data HieType a = HAppTy a a -- data Type = AppTy Type Type + | HFunTy a a -- | FunTy Type Type + | ... + + type TypeIndex = Int + +Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)', +where the 'TypeIndex's in the 'HieType' are references to other elements of the +array. Types recovered from GHC are deduplicated and stored in this compressed +form with sharing of subtrees. +-} + +type TypeIndex = Int + +-- | A flattened version of 'Type'. +-- +-- See Note [Efficient serialization of redundant type info] +data HieType a + = HTyVarTy Name + | HAppTy a (HieArgs a) + | HTyConApp IfaceTyCon (HieArgs a) + | HForAllTy ((Name, a),ArgFlag) a + | HFunTy a a + | HQualTy a a -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy') + | HLitTy IfaceTyLit + | HCastTy a + | HCoercionTy + deriving (Functor, Foldable, Traversable, Eq) + +type HieTypeFlat = HieType TypeIndex + +-- | Roughly isomorphic to the original core 'Type'. +newtype HieTypeFix = Roll (HieType (HieTypeFix)) + +instance Binary (HieType TypeIndex) where + put_ bh (HTyVarTy n) = do + putByte bh 0 + put_ bh n + put_ bh (HAppTy a b) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh (HTyConApp n xs) = do + putByte bh 2 + put_ bh n + put_ bh xs + put_ bh (HForAllTy bndr a) = do + putByte bh 3 + put_ bh bndr + put_ bh a + put_ bh (HFunTy a b) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh (HQualTy a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (HLitTy l) = do + putByte bh 6 + put_ bh l + put_ bh (HCastTy a) = do + putByte bh 7 + put_ bh a + put_ bh (HCoercionTy) = putByte bh 8 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> HTyVarTy <$> get bh + 1 -> HAppTy <$> get bh <*> get bh + 2 -> HTyConApp <$> get bh <*> get bh + 3 -> HForAllTy <$> get bh <*> get bh + 4 -> HFunTy <$> get bh <*> get bh + 5 -> HQualTy <$> get bh <*> get bh + 6 -> HLitTy <$> get bh + 7 -> HCastTy <$> get bh + 8 -> return HCoercionTy + _ -> panic "Binary (HieArgs Int): invalid tag" + + +-- | A list of type arguments along with their respective visibilities (ie. is +-- this an argument that would return 'True' for 'isVisibleArgFlag'?). +newtype HieArgs a = HieArgs [(Bool,a)] + deriving (Functor, Foldable, Traversable, Eq) + +instance Binary (HieArgs TypeIndex) where + put_ bh (HieArgs xs) = put_ bh xs + get bh = HieArgs <$> get bh + +-- | Mapping from filepaths (represented using 'FastString') to the +-- corresponding AST +newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) } + deriving (Functor, Foldable, Traversable) + +instance Binary (HieASTs TypeIndex) where + put_ bh asts = put_ bh $ M.toAscList $ getAsts asts + get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) + + +data HieAST a = + Node + { nodeInfo :: NodeInfo a + , nodeSpan :: Span + , nodeChildren :: [HieAST a] + } deriving (Functor, Foldable, Traversable) + +instance Binary (HieAST TypeIndex) where + put_ bh ast = do + put_ bh $ nodeInfo ast + put_ bh $ nodeSpan ast + put_ bh $ nodeChildren ast + + get bh = Node + <$> get bh + <*> get bh + <*> get bh + + +-- | The information stored in one AST node. +-- +-- The type parameter exists to provide flexibility in representation of types +-- (see Note [Efficient serialization of redundant type info]). +data NodeInfo a = NodeInfo + { nodeAnnotations :: S.Set (FastString,FastString) + -- ^ (name of the AST node constructor, name of the AST node Type) + + , nodeType :: [a] + -- ^ The Haskell types of this node, if any. + + , nodeIdentifiers :: NodeIdentifiers a + -- ^ All the identifiers and their details + } deriving (Functor, Foldable, Traversable) + +instance Binary (NodeInfo TypeIndex) where + put_ bh ni = do + put_ bh $ S.toAscList $ nodeAnnotations ni + put_ bh $ nodeType ni + put_ bh $ M.toList $ nodeIdentifiers ni + get bh = NodeInfo + <$> fmap (S.fromDistinctAscList) (get bh) + <*> get bh + <*> fmap (M.fromList) (get bh) + +type Identifier = Either ModuleName Name + +type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a) + +-- | Information associated with every identifier +-- +-- We need to include types with identifiers because sometimes multiple +-- identifiers occur in the same span(Overloaded Record Fields and so on) +data IdentifierDetails a = IdentifierDetails + { identType :: Maybe a + , identInfo :: S.Set ContextInfo + } deriving (Eq, Functor, Foldable, Traversable) + +instance Outputable a => Outputable (IdentifierDetails a) where + ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x) + +instance Semigroup (IdentifierDetails a) where + d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2) + (S.union (identInfo d1) (identInfo d2)) + +instance Monoid (IdentifierDetails a) where + mempty = IdentifierDetails Nothing S.empty + +instance Binary (IdentifierDetails TypeIndex) where + put_ bh dets = do + put_ bh $ identType dets + put_ bh $ S.toAscList $ identInfo dets + get bh = IdentifierDetails + <$> get bh + <*> fmap (S.fromDistinctAscList) (get bh) + + +-- | Different contexts under which identifiers exist +data ContextInfo + = Use -- ^ regular variable + | MatchBind + | IEThing IEType -- ^ import/export + | TyDecl + + -- | Value binding + | ValBind + BindType -- ^ whether or not the binding is in an instance + Scope -- ^ scope over which the value is bound + (Maybe Span) -- ^ span of entire binding + + -- | Pattern binding + -- + -- This case is tricky because the bound identifier can be used in two + -- distinct scopes. Consider the following example (with @-XViewPatterns@) + -- + -- @ + -- do (b, a, (a -> True)) <- bar + -- foo a + -- @ + -- + -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and + -- in the rest of the @do@-block in @foo a@. + | PatternBind + Scope -- ^ scope /in the pattern/ (the variable bound can be used + -- further in the pattern) + Scope -- ^ rest of the scope outside the pattern + (Maybe Span) -- ^ span of entire binding + + | ClassTyDecl (Maybe Span) + + -- | Declaration + | Decl + DeclType -- ^ type of declaration + (Maybe Span) -- ^ span of entire binding + + -- | Type variable + | TyVarBind Scope TyVarScope + + -- | Record field + | RecField RecFieldContext (Maybe Span) + deriving (Eq, Ord, Show) + +instance Outputable ContextInfo where + ppr = text . show + +instance Binary ContextInfo where + put_ bh Use = putByte bh 0 + put_ bh (IEThing t) = do + putByte bh 1 + put_ bh t + put_ bh TyDecl = putByte bh 2 + put_ bh (ValBind bt sc msp) = do + putByte bh 3 + put_ bh bt + put_ bh sc + put_ bh msp + put_ bh (PatternBind a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (ClassTyDecl sp) = do + putByte bh 5 + put_ bh sp + put_ bh (Decl a b) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh (TyVarBind a b) = do + putByte bh 7 + put_ bh a + put_ bh b + put_ bh (RecField a b) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh MatchBind = putByte bh 9 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return Use + 1 -> IEThing <$> get bh + 2 -> return TyDecl + 3 -> ValBind <$> get bh <*> get bh <*> get bh + 4 -> PatternBind <$> get bh <*> get bh <*> get bh + 5 -> ClassTyDecl <$> get bh + 6 -> Decl <$> get bh <*> get bh + 7 -> TyVarBind <$> get bh <*> get bh + 8 -> RecField <$> get bh <*> get bh + 9 -> return MatchBind + _ -> panic "Binary ContextInfo: invalid tag" + + +-- | Types of imports and exports +data IEType + = Import + | ImportAs + | ImportHiding + | Export + deriving (Eq, Enum, Ord, Show) + +instance Binary IEType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data RecFieldContext + = RecFieldDecl + | RecFieldAssign + | RecFieldMatch + | RecFieldOcc + deriving (Eq, Enum, Ord, Show) + +instance Binary RecFieldContext where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data BindType + = RegularBind + | InstanceBind + deriving (Eq, Ord, Show, Enum) + +instance Binary BindType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data DeclType + = FamDec -- ^ type or data family + | SynDec -- ^ type synonym + | DataDec -- ^ data declaration + | ConDec -- ^ constructor declaration + | PatSynDec -- ^ pattern synonym + | ClassDec -- ^ class declaration + | InstDec -- ^ instance declaration + deriving (Eq, Ord, Show, Enum) + +instance Binary DeclType where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + + +data Scope + = NoScope + | LocalScope Span + | ModuleScope + deriving (Eq, Ord, Show, Typeable, Data) + +instance Outputable Scope where + ppr NoScope = text "NoScope" + ppr (LocalScope sp) = text "LocalScope" <+> ppr sp + ppr ModuleScope = text "ModuleScope" + +instance Binary Scope where + put_ bh NoScope = putByte bh 0 + put_ bh (LocalScope span) = do + putByte bh 1 + put_ bh span + put_ bh ModuleScope = putByte bh 2 + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> return NoScope + 1 -> LocalScope <$> get bh + 2 -> return ModuleScope + _ -> panic "Binary Scope: invalid tag" + + +-- | Scope of a type variable. +-- +-- This warrants a data type apart from 'Scope' because of complexities +-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For +-- example, consider: +-- +-- @ +-- foo, bar, baz :: forall a. a -> a +-- @ +-- +-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we +-- need a list of scopes to keep track of this. Furthermore, this list cannot be +-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@. +-- +-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@ +-- which later gets resolved into a 'ResolvedScopes'. +data TyVarScope + = ResolvedScopes [Scope] + + -- | Unresolved scopes should never show up in the final @.hie@ file + | UnresolvedScope + [Name] -- ^ names of the definitions over which the scope spans + (Maybe Span) -- ^ the location of the instance/class declaration for + -- the case where the type variable is declared in a + -- method type signature + deriving (Eq, Ord) + +instance Show TyVarScope where + show (ResolvedScopes sc) = show sc + show _ = error "UnresolvedScope" + +instance Binary TyVarScope where + put_ bh (ResolvedScopes xs) = do + putByte bh 0 + put_ bh xs + put_ bh (UnresolvedScope ns span) = do + putByte bh 1 + put_ bh ns + put_ bh span + + get bh = do + (t :: Word8) <- get bh + case t of + 0 -> ResolvedScopes <$> get bh + 1 -> UnresolvedScope <$> get bh <*> get bh + _ -> panic "Binary TyVarScope: invalid tag" diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs new file mode 100644 index 0000000000..b0d71f34b4 --- /dev/null +++ b/compiler/GHC/Iface/Ext/Utils.hs @@ -0,0 +1,455 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +module GHC.Iface.Ext.Utils where + +import GhcPrelude + +import CoreMap +import DynFlags ( DynFlags ) +import FastString ( FastString, mkFastString ) +import GHC.Iface.Type +import Name hiding (varName) +import Outputable ( renderWithStyle, ppr, defaultUserStyle ) +import SrcLoc +import GHC.CoreToIface +import TyCon +import TyCoRep +import Type +import Var +import VarEnv + +import GHC.Iface.Ext.Types + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.IntMap.Strict as IM +import qualified Data.Array as A +import Data.Data ( typeOf, typeRepTyCon, Data(toConstr) ) +import Data.Maybe ( maybeToList ) +import Data.Monoid +import Data.Traversable ( for ) +import Control.Monad.Trans.State.Strict hiding (get) + + +generateReferencesMap + :: Foldable f + => f (HieAST a) + -> M.Map Identifier [(Span, IdentifierDetails a)] +generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty + where + go ast = M.unionsWith (++) (this : map go (nodeChildren ast)) + where + this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast + +renderHieType :: DynFlags -> HieTypeFix -> String +renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty + where sty = defaultUserStyle df + +resolveVisibility :: Type -> [Type] -> [(Bool,Type)] +resolveVisibility kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = [] + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + | isVisibleArgFlag vis = (True , t) : ts' + | otherwise = (False, t) : ts' + where + ts' = go (extendTvSubst env tv t) res ts + + go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps + = (True,t) : (go env res ts) + + go env (TyVarTy tv) ts + | Just ki <- lookupTyVar env tv = go env ki ts + go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded + +foldType :: (HieType a -> a) -> HieTypeFix -> a +foldType f (Roll t) = f $ fmap (foldType f) t + +hieTypeToIface :: HieTypeFix -> IfaceType +hieTypeToIface = foldType go + where + go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n + go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b) + go (HLitTy l) = IfaceLitTy l + go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k) + in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t + go (HFunTy a b) = IfaceFunTy VisArg a b + go (HQualTy pred b) = IfaceFunTy InvisArg pred b + go (HCastTy a) = a + go HCoercionTy = IfaceTyVar "<coercion type>" + go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs) + + -- This isn't fully faithful - we can't produce the 'Inferred' case + hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs + hieToIfaceArgs (HieArgs xs) = go' xs + where + go' [] = IA_Nil + go' ((True ,x):xs) = IA_Arg x Required $ go' xs + go' ((False,x):xs) = IA_Arg x Specified $ go' xs + +data HieTypeState + = HTS + { tyMap :: !(TypeMap TypeIndex) + , htyTable :: !(IM.IntMap HieTypeFlat) + , freshIndex :: !TypeIndex + } + +initialHTS :: HieTypeState +initialHTS = HTS emptyTypeMap IM.empty 0 + +freshTypeIndex :: State HieTypeState TypeIndex +freshTypeIndex = do + index <- gets freshIndex + modify' $ \hts -> hts { freshIndex = index+1 } + return index + +compressTypes + :: HieASTs Type + -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) +compressTypes asts = (a, arr) + where + (a, (HTS _ m i)) = flip runState initialHTS $ + for asts $ \typ -> do + i <- getTypeIndex typ + return i + arr = A.array (0,i-1) (IM.toList m) + +recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix +recoverFullType i m = go i + where + go i = Roll $ fmap go (m A.! i) + +getTypeIndex :: Type -> State HieTypeState TypeIndex +getTypeIndex t + | otherwise = do + tm <- gets tyMap + case lookupTypeMap tm t of + Just i -> return i + Nothing -> do + ht <- go t + extendHTS t ht + where + extendHTS t ht = do + i <- freshTypeIndex + modify' $ \(HTS tm tt fi) -> + HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi + return i + + go (TyVarTy v) = return $ HTyVarTy $ varName v + go ty@(AppTy _ _) = do + let (head,args) = splitAppTys ty + visArgs = HieArgs $ resolveVisibility (typeKind head) args + ai <- getTypeIndex head + argsi <- mapM getTypeIndex visArgs + return $ HAppTy ai argsi + go (TyConApp f xs) = do + let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs + is <- mapM getTypeIndex visArgs + return $ HTyConApp (toIfaceTyCon f) is + go (ForAllTy (Bndr v a) t) = do + k <- getTypeIndex (varType v) + i <- getTypeIndex t + return $ HForAllTy ((varName v,k),a) i + go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do + ai <- getTypeIndex a + bi <- getTypeIndex b + return $ case af of + InvisArg -> HQualTy ai bi + VisArg -> HFunTy ai bi + go (LitTy a) = return $ HLitTy $ toIfaceTyLit a + go (CastTy t _) = do + i <- getTypeIndex t + return $ HCastTy i + go (CoercionTy _) = return HCoercionTy + +resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a) +resolveTyVarScopes asts = M.map go asts + where + go ast = resolveTyVarScopeLocal ast asts + +resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a +resolveTyVarScopeLocal ast asts = go ast + where + resolveNameScope dets = dets{identInfo = + S.map resolveScope (identInfo dets)} + resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBinding name asts] + ] + resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) = + TyVarBind sc $ ResolvedScopes + [ LocalScope binding + | name <- names + , Just binding <- [getNameBindingInClass name sp asts] + ] + resolveScope scope = scope + go (Node info span children) = Node info' span $ map go children + where + info' = info { nodeIdentifiers = idents } + idents = M.map resolveNameScope $ nodeIdentifiers info + +getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span +getNameBinding n asts = do + (_,msp) <- getNameScopeAndBinding n asts + msp + +getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope] +getNameScope n asts = do + (scopes,_) <- getNameScopeAndBinding n asts + return scopes + +getNameBindingInClass + :: Name + -> Span + -> M.Map FastString (HieAST a) + -> Maybe Span +getNameBindingInClass n sp asts = do + ast <- M.lookup (srcSpanFile sp) asts + getFirst $ foldMap First $ do + child <- flattenAst ast + dets <- maybeToList + $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return (getFirst binding) + +getNameScopeAndBinding + :: Name + -> M.Map FastString (HieAST a) + -> Maybe ([Scope], Maybe Span) +getNameScopeAndBinding n asts = case nameSrcSpan n of + RealSrcSpan sp -> do -- @Maybe + ast <- M.lookup (srcSpanFile sp) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) + _ -> Nothing + +getScopeFromContext :: ContextInfo -> Maybe [Scope] +getScopeFromContext (ValBind _ sc _) = Just [sc] +getScopeFromContext (PatternBind a b _) = Just [a, b] +getScopeFromContext (ClassTyDecl _) = Just [ModuleScope] +getScopeFromContext (Decl _ _) = Just [ModuleScope] +getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs +getScopeFromContext (TyVarBind a _) = Just [a] +getScopeFromContext _ = Nothing + +getBindSiteFromContext :: ContextInfo -> Maybe Span +getBindSiteFromContext (ValBind _ _ sp) = sp +getBindSiteFromContext (PatternBind _ _ sp) = sp +getBindSiteFromContext _ = Nothing + +flattenAst :: HieAST a -> [HieAST a] +flattenAst n = + n : concatMap flattenAst (nodeChildren n) + +smallestContainingSatisfying + :: Span + -> (HieAST a -> Bool) + -> HieAST a + -> Maybe (HieAST a) +smallestContainingSatisfying sp cond node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . smallestContainingSatisfying sp cond) $ + nodeChildren node + , First $ if cond node then Just node else Nothing + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a) +selectLargestContainedBy sp node + | sp `containsSpan` nodeSpan node = Just node + | nodeSpan node `containsSpan` sp = + getFirst $ foldMap (First . selectLargestContainedBy sp) $ + nodeChildren node + | otherwise = Nothing + +selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a) +selectSmallestContaining sp node + | nodeSpan node `containsSpan` sp = getFirst $ mconcat + [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node + , First (Just node) + ] + | sp `containsSpan` nodeSpan node = Nothing + | otherwise = Nothing + +definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool +definedInAsts asts n = case nameSrcSpan n of + RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts + _ -> False + +isOccurrence :: ContextInfo -> Bool +isOccurrence Use = True +isOccurrence _ = False + +scopeContainsSpan :: Scope -> Span -> Bool +scopeContainsSpan NoScope _ = False +scopeContainsSpan ModuleScope _ = True +scopeContainsSpan (LocalScope a) b = a `containsSpan` b + +-- | One must contain the other. Leaf nodes cannot contain anything +combineAst :: HieAST Type -> HieAST Type -> HieAST Type +combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys) + | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys) + | aSpn `containsSpan` bSpn = combineAst b a +combineAst a (Node xs span children) = Node xs span (insertAst a children) + +-- | Insert an AST in a sorted list of disjoint Asts +insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type] +insertAst x = mergeAsts [x] + +-- | Merge two nodes together. +-- +-- Precondition and postcondition: elements in 'nodeType' are ordered. +combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type +(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) = + NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd) + where + mergeSorted :: [Type] -> [Type] -> [Type] + mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of + LT -> a : mergeSorted as lb + EQ -> a : mergeSorted as bs + GT -> b : mergeSorted la bs + mergeSorted as [] = as + mergeSorted [] bs = bs + + +{- | Merge two sorted, disjoint lists of ASTs, combining when necessary. + +In the absence of position-altering pragmas (ex: @# line "file.hs" 3@), +different nodes in an AST tree should either have disjoint spans (in +which case you can say for sure which one comes first) or one span +should be completely contained in the other (in which case the contained +span corresponds to some child node). + +However, since Haskell does have position-altering pragmas it /is/ +possible for spans to be overlapping. Here is an example of a source file +in which @foozball@ and @quuuuuux@ have overlapping spans: + +@ +module Baz where + +# line 3 "Baz.hs" +foozball :: Int +foozball = 0 + +# line 3 "Baz.hs" +bar, quuuuuux :: Int +bar = 1 +quuuuuux = 2 +@ + +In these cases, we just do our best to produce sensible `HieAST`'s. The blame +should be laid at the feet of whoever wrote the line pragmas in the first place +(usually the C preprocessor...). +-} +mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type] +mergeAsts xs [] = xs +mergeAsts [] ys = ys +mergeAsts xs@(a:as) ys@(b:bs) + | span_a `containsSpan` span_b = mergeAsts (combineAst a b : as) bs + | span_b `containsSpan` span_a = mergeAsts as (combineAst a b : bs) + | span_a `rightOf` span_b = b : mergeAsts xs bs + | span_a `leftOf` span_b = a : mergeAsts as ys + + -- These cases are to work around ASTs that are not fully disjoint + | span_a `startsRightOf` span_b = b : mergeAsts as ys + | otherwise = a : mergeAsts as ys + where + span_a = nodeSpan a + span_b = nodeSpan b + +rightOf :: Span -> Span -> Bool +rightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +leftOf :: Span -> Span -> Bool +leftOf s1 s2 + = (srcSpanEndLine s1, srcSpanEndCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + +startsRightOf :: Span -> Span -> Bool +startsRightOf s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + >= (srcSpanStartLine s2, srcSpanStartCol s2) + +-- | combines and sorts ASTs using a merge sort +mergeSortAsts :: [HieAST Type] -> [HieAST Type] +mergeSortAsts = go . map pure + where + go [] = [] + go [xs] = xs + go xss = go (mergePairs xss) + mergePairs [] = [] + mergePairs [xs] = [xs] + mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss + +simpleNodeInfo :: FastString -> FastString -> NodeInfo a +simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty + +locOnly :: SrcSpan -> [HieAST a] +locOnly (RealSrcSpan span) = + [Node e span []] + where e = NodeInfo S.empty [] M.empty +locOnly _ = [] + +mkScope :: SrcSpan -> Scope +mkScope (RealSrcSpan sp) = LocalScope sp +mkScope _ = NoScope + +mkLScope :: Located a -> Scope +mkLScope = mkScope . getLoc + +combineScopes :: Scope -> Scope -> Scope +combineScopes ModuleScope _ = ModuleScope +combineScopes _ ModuleScope = ModuleScope +combineScopes NoScope x = x +combineScopes x NoScope = x +combineScopes (LocalScope a) (LocalScope b) = + mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b) + +{-# INLINEABLE makeNode #-} +makeNode + :: (Applicative m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> m [HieAST b] +makeNode x spn = pure $ case spn of + RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x + +{-# INLINEABLE makeTypeNode #-} +makeTypeNode + :: (Applicative m, Data a) + => a -- ^ helps fill in 'nodeAnnotations' (with 'Data') + -> SrcSpan -- ^ return an empty list if this is unhelpful + -> Type -- ^ type to associate with the node + -> m [HieAST Type] +makeTypeNode x spn etyp = pure $ case spn of + RealSrcSpan span -> + [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []] + _ -> [] + where + cons = mkFastString . show . toConstr $ x + typ = mkFastString . show . typeRepTyCon . typeOf $ x diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs new file mode 100644 index 0000000000..77eefc4c7b --- /dev/null +++ b/compiler/GHC/Iface/Load.hs @@ -0,0 +1,1289 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Loading interface files +-} + +{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module GHC.Iface.Load ( + -- Importing one thing + tcLookupImported_maybe, importDecl, + checkWiredInTyCon, ifCheckWiredInThing, + + -- RnM/TcM functions + loadModuleInterface, loadModuleInterfaces, + loadSrcInterface, loadSrcInterface_maybe, + loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule, + + -- IfM functions + loadInterface, + loadSysInterface, loadUserInterface, loadPluginInterface, + findAndReadIface, readIface, -- Used when reading the module's old interface + loadDecls, -- Should move to GHC.IfaceToCore and be renamed + initExternalPackageState, + moduleFreeHolesPrecise, + needWiredInHomeIface, loadWiredInHomeIface, + + pprModIfaceSimple, + ifaceStats, pprModIface, showIface + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} GHC.IfaceToCore + ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst + , tcIfaceAnnotations, tcIfaceCompleteSigs ) + +import DynFlags +import GHC.Iface.Syntax +import GHC.Iface.Env +import HscTypes + +import BasicTypes hiding (SuccessFlag(..)) +import TcRnMonad + +import Constants +import PrelNames +import PrelInfo +import PrimOp ( allThePrimOps, primOpFixity, primOpOcc ) +import MkId ( seqId ) +import TysPrim ( funTyConName ) +import Rules +import TyCon +import Annotations +import InstEnv +import FamInstEnv +import Name +import NameEnv +import Avail +import Module +import Maybes +import ErrUtils +import Finder +import UniqFM +import SrcLoc +import Outputable +import GHC.Iface.Binary +import Panic +import Util +import FastString +import Fingerprint +import Hooks +import FieldLabel +import GHC.Iface.Rename +import UniqDSet +import Plugins + +import Control.Monad +import Control.Exception +import Data.IORef +import System.FilePath + +{- +************************************************************************ +* * +* tcImportDecl is the key function for "faulting in" * +* imported things +* * +************************************************************************ + +The main idea is this. We are chugging along type-checking source code, and +find a reference to GHC.Base.map. We call tcLookupGlobal, which doesn't find +it in the EPS type envt. So it + 1 loads GHC.Base.hi + 2 gets the decl for GHC.Base.map + 3 typechecks it via tcIfaceDecl + 4 and adds it to the type env in the EPS + +Note that DURING STEP 4, we may find that map's type mentions a type +constructor that also + +Notice that for imported things we read the current version from the EPS +mutable variable. This is important in situations like + ...$(e1)...$(e2)... +where the code that e1 expands to might import some defns that +also turn out to be needed by the code that e2 expands to. +-} + +tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +-- Returns (Failed err) if we can't find the interface file for the thing +tcLookupImported_maybe name + = do { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of + Just thing -> return (Succeeded thing) + Nothing -> tcImportDecl_maybe name } + +tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +-- Entry point for *source-code* uses of importDecl +tcImportDecl_maybe name + | Just thing <- wiredInNameTyThing_maybe name + = do { when (needWiredInHomeIface thing) + (initIfaceTcRn (loadWiredInHomeIface name)) + -- See Note [Loading instances for wired-in things] + ; return (Succeeded thing) } + | otherwise + = initIfaceTcRn (importDecl name) + +importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) +-- Get the TyThing for this Name from an interface file +-- It's not a wired-in thing -- the caller caught that +importDecl name + = ASSERT( not (isWiredInName name) ) + do { traceIf nd_doc + + -- Load the interface, which should populate the PTE + ; mb_iface <- ASSERT2( isExternalName name, ppr name ) + loadInterface nd_doc (nameModule name) ImportBySystem + ; case mb_iface of { + Failed err_msg -> return (Failed err_msg) ; + Succeeded _ -> do + + -- Now look it up again; this time we should find it + { eps <- getEps + ; case lookupTypeEnv (eps_PTE eps) name of + Just thing -> return $ Succeeded thing + Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) + $$ not_found_msg + in return $ Failed doc + }}} + where + nd_doc = text "Need decl for" <+> ppr name + not_found_msg = hang (text "Can't find interface-file declaration for" <+> + pprNameSpace (nameNameSpace name) <+> ppr name) + 2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file", + text "Use -ddump-if-trace to get an idea of which file caused the error"]) + found_things_msg eps = + hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon) + 2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps)) + where + is_interesting thing = nameModule name == nameModule (getName thing) + + +{- +************************************************************************ +* * + Checks for wired-in things +* * +************************************************************************ + +Note [Loading instances for wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to make sure that we have at least *read* the interface files +for any module with an instance decl or RULE that we might want. + +* If the instance decl is an orphan, we have a whole separate mechanism + (loadOrphanModules) + +* If the instance decl is not an orphan, then the act of looking at the + TyCon or Class will force in the defining module for the + TyCon/Class, and hence the instance decl + +* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface; + but we must make sure we read its interface in case it has instances or + rules. That is what GHC.Iface.Load.loadWiredInHomeIface does. It's called + from GHC.IfaceToCore.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing} + +* HOWEVER, only do this for TyCons. There are no wired-in Classes. There + are some wired-in Ids, but we don't want to load their interfaces. For + example, Control.Exception.Base.recSelError is wired in, but that module + is compiled late in the base library, and we don't want to force it to + load before it's been compiled! + +All of this is done by the type checker. The renamer plays no role. +(It used to, but no longer.) +-} + +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure that the home module of the TyCon (and hence its instances) +-- are loaded. See Note [Loading instances for wired-in things] +-- It might not be a wired-in tycon (see the calls in TcUnify), +-- in which case this is a no-op. +checkWiredInTyCon tc + | not (isWiredInName tc_name) + = return () + | otherwise + = do { mod <- getModule + ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod) + ; ASSERT( isExternalName tc_name ) + when (mod /= nameModule tc_name) + (initIfaceTcRn (loadWiredInHomeIface tc_name)) + -- Don't look for (non-existent) Float.hi when + -- compiling Float.hs, which mentions Float of course + -- A bit yukky to call initIfaceTcRn here + } + where + tc_name = tyConName tc + +ifCheckWiredInThing :: TyThing -> IfL () +-- Even though we are in an interface file, we want to make +-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double) +-- Ditto want to ensure that RULES are loaded too +-- See Note [Loading instances for wired-in things] +ifCheckWiredInThing thing + = do { mod <- getIfModule + -- Check whether we are typechecking the interface for this + -- very module. E.g when compiling the base library in --make mode + -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in + -- the HPT, so without the test we'll demand-load it into the PIT! + -- C.f. the same test in checkWiredInTyCon above + ; let name = getName thing + ; ASSERT2( isExternalName name, ppr name ) + when (needWiredInHomeIface thing && mod /= nameModule name) + (loadWiredInHomeIface name) } + +needWiredInHomeIface :: TyThing -> Bool +-- Only for TyCons; see Note [Loading instances for wired-in things] +needWiredInHomeIface (ATyCon {}) = True +needWiredInHomeIface _ = False + + +{- +************************************************************************ +* * + loadSrcInterface, loadOrphanModules, loadInterfaceForName + + These three are called from TcM-land +* * +************************************************************************ +-} + +-- | Load the interface corresponding to an @import@ directive in +-- source code. On a failure, fail in the monad with an error message. +loadSrcInterface :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM ModIface + +loadSrcInterface doc mod want_boot maybe_pkg + = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg + ; case res of + Failed err -> failWithTc err + Succeeded iface -> return iface } + +-- | Like 'loadSrcInterface', but returns a 'MaybeErr'. +loadSrcInterface_maybe :: SDoc + -> ModuleName + -> IsBootInterface -- {-# SOURCE #-} ? + -> Maybe FastString -- "package", if any + -> RnM (MaybeErr MsgDoc ModIface) + +loadSrcInterface_maybe doc mod want_boot maybe_pkg + -- We must first find which Module this import refers to. This involves + -- calling the Finder, which as a side effect will search the filesystem + -- and create a ModLocation. If successful, loadIface will read the + -- interface; it will call the Finder again, but the ModLocation will be + -- cached from the first search. + = do { hsc_env <- getTopEnv + ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg + ; case res of + Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) + -- TODO: Make sure this error message is good + err -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) } + +-- | Load interface directly for a fully qualified 'Module'. (This is a fairly +-- rare operation, but in particular it is used to load orphan modules +-- in order to pull their instances into the global package table and to +-- handle some operations in GHCi). +loadModuleInterface :: SDoc -> Module -> TcM ModIface +loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod) + +-- | Load interfaces for a collection of modules. +loadModuleInterfaces :: SDoc -> [Module] -> TcM () +loadModuleInterfaces doc mods + | null mods = return () + | otherwise = initIfaceTcRn (mapM_ load mods) + where + load mod = loadSysInterface (doc <+> parens (ppr mod)) mod + +-- | Loads the interface for a given Name. +-- Should only be called for an imported name; +-- otherwise loadSysInterface may not find the interface +loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName doc name + = do { when debugIsOn $ -- Check pre-condition + do { this_mod <- getModule + ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) } + ; ASSERT2( isExternalName name, ppr name ) + initIfaceTcRn $ loadSysInterface doc (nameModule name) } + +-- | Only loads the interface for external non-local names. +loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface) +loadInterfaceForNameMaybe doc name + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name || not (isExternalName name) + then return Nothing + else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name)) + } + +-- | Loads the interface for a given Module. +loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface +loadInterfaceForModule doc m + = do + -- Should not be called with this module + when debugIsOn $ do + this_mod <- getModule + MASSERT2( this_mod /= m, ppr m <+> parens doc ) + initIfaceTcRn $ loadSysInterface doc m + +{- +********************************************************* +* * + loadInterface + + The main function to load an interface + for an imported module, and put it in + the External Package State +* * +********************************************************* +-} + +-- | An 'IfM' function to load the home interface for a wired-in thing, +-- so that we're sure that we see its instance declarations and rules +-- See Note [Loading instances for wired-in things] +loadWiredInHomeIface :: Name -> IfM lcl () +loadWiredInHomeIface name + = ASSERT( isWiredInName name ) + do _ <- loadSysInterface doc (nameModule name); return () + where + doc = text "Need home interface for wired-in thing" <+> ppr name + +------------------ +-- | Loads a system interface and throws an exception if it fails +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface +loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem + +------------------ +-- | Loads a user interface and throws an exception if it fails. The first parameter indicates +-- whether we should import the boot variant of the module +loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface +loadUserInterface is_boot doc mod_name + = loadInterfaceWithException doc mod_name (ImportByUser is_boot) + +loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface +loadPluginInterface doc mod_name + = loadInterfaceWithException doc mod_name ImportByPlugin + +------------------ +-- | A wrapper for 'loadInterface' that throws an exception if it fails +loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface +loadInterfaceWithException doc mod_name where_from + = withException (loadInterface doc mod_name where_from) + +------------------ +loadInterface :: SDoc -> Module -> WhereFrom + -> IfM lcl (MaybeErr MsgDoc ModIface) + +-- loadInterface looks in both the HPT and PIT for the required interface +-- If not found, it loads it, and puts it in the PIT (always). + +-- If it can't find a suitable interface file, we +-- a) modify the PackageIfaceTable to have an empty entry +-- (to avoid repeated complaints) +-- b) return (Left message) +-- +-- It's not necessarily an error for there not to be an interface +-- file -- perhaps the module has changed, and that interface +-- is no longer used + +loadInterface doc_str mod from + | isHoleModule mod + -- Hole modules get special treatment + = do dflags <- getDynFlags + -- Redo search for our local hole module + loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from + | otherwise + = withTimingSilentD (text "loading interface") (pure ()) $ + do { -- Read the state + (eps,hpt) <- getEpsAndHpt + ; gbl_env <- getGblEnv + + ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) + + -- Check whether we have the interface already + ; dflags <- getDynFlags + ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { + Just iface + -> return (Succeeded iface) ; -- Already loaded + -- The (src_imp == mi_boot iface) test checks that the already-loaded + -- interface isn't a boot iface. This can conceivably happen, + -- if an earlier import had a before we got to real imports. I think. + _ -> do { + + -- READ THE MODULE IN + ; read_result <- case (wantHiBootFile dflags eps mod from) of + Failed err -> return (Failed err) + Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod + ; case read_result of { + Failed err -> do + { let fake_iface = emptyFullModIface mod + + ; updateEps_ $ \eps -> + eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } + -- Not found, so add an empty iface to + -- the EPS map so that we don't look again + + ; return (Failed err) } ; + + -- Found and parsed! + -- We used to have a sanity check here that looked for: + -- * System importing .. + -- * a home package module .. + -- * that we know nothing about (mb_dep == Nothing)! + -- + -- But this is no longer valid because thNameToGhcName allows users to + -- cause the system to load arbitrary interfaces (by supplying an appropriate + -- Template Haskell original-name). + Succeeded (iface, loc) -> + let + loc_doc = text loc + in + initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do + + dontLeakTheHPT $ do + + -- Load the new ModIface into the External Package State + -- Even home-package interfaces loaded by loadInterface + -- (which only happens in OneShot mode; in Batch/Interactive + -- mode, home-package modules are loaded one by one into the HPT) + -- are put in the EPS. + -- + -- The main thing is to add the ModIface to the PIT, but + -- we also take the + -- IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules, + -- out of the ModIface and put them into the big EPS pools + + -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined + --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). + -- If we do loadExport first the wrong info gets into the cache (unless we + -- explicitly tag each export which seems a bit of a bore) + + ; ignore_prags <- goptM Opt_IgnoreInterfacePragmas + ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) + ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) + ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + + ; let { final_iface = iface { + mi_decls = panic "No mi_decls in PIT", + mi_insts = panic "No mi_insts in PIT", + mi_fam_insts = panic "No mi_fam_insts in PIT", + mi_rules = panic "No mi_rules in PIT", + mi_anns = panic "No mi_anns in PIT" + } + } + + ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod + -- Warn warn against an EPS-updating import + -- of one's own boot file! (one-shot only) + -- See Note [Loading your own hi-boot file] + -- in GHC.Iface.Utils. + + ; WARN( bad_boot, ppr mod ) + updateEps_ $ \ eps -> + if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface + then eps + else if bad_boot + -- See Note [Loading your own hi-boot file] + then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls } + else + eps { + eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rule_base = extendRuleBaseList (eps_rule_base eps) + new_eps_rules, + eps_complete_matches + = extendCompleteMatchMap + (eps_complete_matches eps) + new_eps_complete_sigs, + eps_inst_env = extendInstEnvList (eps_inst_env eps) + new_eps_insts, + eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps) + new_eps_fam_insts, + eps_ann_env = extendAnnEnvList (eps_ann_env eps) + new_eps_anns, + eps_mod_fam_inst_env + = let + fam_inst_env = + extendFamInstEnvList emptyFamInstEnv + new_eps_fam_insts + in + extendModuleEnv (eps_mod_fam_inst_env eps) + mod + fam_inst_env, + eps_stats = addEpsInStats (eps_stats eps) + (length new_eps_decls) + (length new_eps_insts) + (length new_eps_rules) } + + ; -- invoke plugins + res <- withPlugins dflags interfaceLoadAction final_iface + ; return (Succeeded res) + }}}} + +{- Note [Loading your own hi-boot file] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, when compiling module M, we should not +load M.hi boot into the EPS. After all, we are very shortly +going to have full information about M. Moreover, see +Note [Do not update EPS with your own hi-boot] in GHC.Iface.Utils. + +But there is a HORRIBLE HACK here. + +* At the end of tcRnImports, we call checkFamInstConsistency to + check consistency of imported type-family instances + See Note [The type family instance consistency story] in FamInst + +* Alas, those instances may refer to data types defined in M, + if there is a M.hs-boot. + +* And that means we end up loading M.hi-boot, because those + data types are not yet in the type environment. + +But in this weird case, /all/ we need is the types. We don't need +instances, rules etc. And if we put the instances in the EPS +we get "duplicate instance" warnings when we compile the "real" +instance in M itself. Hence the strange business of just updateing +the eps_PTE. + +This really happens in practice. The module HsExpr.hs gets +"duplicate instance" errors if this hack is not present. + +This is a mess. + + +Note [HPT space leak] (#15111) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfL, we defer some work until it is demanded using forkM, such +as building TyThings from IfaceDecls. These thunks are stored in +the ExternalPackageState, and they might never be poked. If we're +not careful, these thunks will capture the state of the loaded +program when we read an interface file, and retain all that data +for ever. + +Therefore, when loading a package interface file , we use a "clean" +version of the HscEnv with all the data about the currently loaded +program stripped out. Most of the fields can be panics because +we'll never read them, but hsc_HPT needs to be empty because this +interface will cause other interfaces to be loaded recursively, and +when looking up those interfaces we use the HPT in loadInterface. +We know that none of the interfaces below here can refer to +home-package modules however, so it's safe for the HPT to be empty. +-} + +dontLeakTheHPT :: IfL a -> IfL a +dontLeakTheHPT thing_inside = do + let + cleanTopEnv HscEnv{..} = + let + -- wrinkle: when we're typechecking in --backpack mode, the + -- instantiation of a signature might reside in the HPT, so + -- this case breaks the assumption that EPS interfaces only + -- refer to other EPS interfaces. We can detect when we're in + -- typechecking-only mode by using hscTarget==HscNothing, and + -- in that case we don't empty the HPT. (admittedly this is + -- a bit of a hack, better suggestions welcome). A number of + -- tests in testsuite/tests/backpack break without this + -- tweak. + !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT + | otherwise = emptyHomePackageTable + in + HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets" + , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph" + , hsc_IC = panic "cleanTopEnv: hsc_IC" + , hsc_HPT = hpt + , .. } + + updTopEnv cleanTopEnv $ do + !_ <- getTopEnv -- force the updTopEnv + thing_inside + + +-- | Returns @True@ if a 'ModIface' comes from an external package. +-- In this case, we should NOT load it into the EPS; the entities +-- should instead come from the local merged signature interface. +is_external_sig :: DynFlags -> ModIface -> Bool +is_external_sig dflags iface = + -- It's a signature iface... + mi_semantic_module iface /= mi_module iface && + -- and it's not from the local package + moduleUnitId (mi_module iface) /= thisPackage dflags + +-- | This is an improved version of 'findAndReadIface' which can also +-- handle the case when a user requests @p[A=<B>]:M@ but we only +-- have an interface for @p[A=<A>]:M@ (the indefinite interface. +-- If we are not trying to build code, we load the interface we have, +-- *instantiating it* according to how the holes are specified. +-- (Of course, if we're actually building code, this is a hard error.) +-- +-- In the presence of holes, 'computeInterface' has an important invariant: +-- to load module M, its set of transitively reachable requirements must +-- have an up-to-date local hi file for that requirement. Note that if +-- we are loading the interface of a requirement, this does not +-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require +-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless +-- we are actually typechecking p.) +computeInterface :: + SDoc -> IsBootInterface -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) +computeInterface doc_str hi_boot_file mod0 = do + MASSERT( not (isHoleModule mod0) ) + dflags <- getDynFlags + case splitModuleInsts mod0 of + (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do + r <- findAndReadIface doc_str imod mod0 hi_boot_file + case r of + Succeeded (iface0, path) -> do + hsc_env <- getTopEnv + r <- liftIO $ + rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) + Nothing iface0 + case r of + Right x -> return (Succeeded (x, path)) + Left errs -> liftIO . throwIO . mkSrcErr $ errs + Failed err -> return (Failed err) + (mod, _) -> + findAndReadIface doc_str mod mod0 hi_boot_file + +-- | Compute the signatures which must be compiled in order to +-- load the interface for a 'Module'. The output of this function +-- is always a subset of 'moduleFreeHoles'; it is more precise +-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes +-- are A and B, B might not depend on A at all! +-- +-- If this is invoked on a signature, this does NOT include the +-- signature itself; e.g. precise free module holes of +-- @p[A=<A>,B=<B>]:B@ never includes B. +moduleFreeHolesPrecise + :: SDoc -> Module + -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) +moduleFreeHolesPrecise doc_str mod + | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) + | otherwise = + case splitModuleInsts mod of + (imod, Just indef) -> do + let insts = indefUnitIdInsts (indefModuleUnitId indef) + traceIf (text "Considering whether to load" <+> ppr mod <+> + text "to compute precise free module holes") + (eps, hpt) <- getEpsAndHpt + case tryEpsAndHpt eps hpt `firstJust` tryDepsCache eps imod insts of + Just r -> return (Succeeded r) + Nothing -> readAndCache imod insts + (_, Nothing) -> return (Succeeded emptyUniqDSet) + where + tryEpsAndHpt eps hpt = + fmap mi_free_holes (lookupIfaceByModule hpt (eps_PIT eps) mod) + tryDepsCache eps imod insts = + case lookupInstalledModuleEnv (eps_free_holes eps) imod of + Just ifhs -> Just (renameFreeHoles ifhs insts) + _otherwise -> Nothing + readAndCache imod insts = do + mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False + case mb_iface of + Succeeded (iface, _) -> do + let ifhs = mi_free_holes iface + -- Cache it + updateEps_ (\eps -> + eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs }) + return (Succeeded (renameFreeHoles ifhs insts)) + Failed err -> return (Failed err) + +wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom + -> MaybeErr MsgDoc IsBootInterface +-- Figure out whether we want Foo.hi or Foo.hi-boot +wantHiBootFile dflags eps mod from + = case from of + ImportByUser usr_boot + | usr_boot && not this_package + -> Failed (badSourceImport mod) + | otherwise -> Succeeded usr_boot + + ImportByPlugin + -> Succeeded False + + ImportBySystem + | not this_package -- If the module to be imported is not from this package + -> Succeeded False -- don't look it up in eps_is_boot, because that is keyed + -- on the ModuleName of *home-package* modules only. + -- We never import boot modules from other packages! + + | otherwise + -> case lookupUFM (eps_is_boot eps) (moduleName mod) of + Just (_, is_boot) -> Succeeded is_boot + Nothing -> Succeeded False + -- The boot-ness of the requested interface, + -- based on the dependencies in directly-imported modules + where + this_package = thisPackage dflags == moduleUnitId mod + +badSourceImport :: Module -> SDoc +badSourceImport mod + = hang (text "You cannot {-# SOURCE #-} import a module from another package") + 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package") + <+> quotes (ppr (moduleUnitId mod))) + +----------------------------------------------------- +-- Loading type/class/value decls +-- We pass the full Module name here, replete with +-- its package info, so that we can build a Name for +-- each binder with the right package info in it +-- All subsequent lookups, including crucially lookups during typechecking +-- the declaration itself, will find the fully-glorious Name +-- +-- We handle ATs specially. They are not main declarations, but also not +-- implicit things (in particular, adding them to `implicitTyThings' would mess +-- things up in the renaming/type checking of source programs). +----------------------------------------------------- + +addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv +addDeclsToPTE pte things = extendNameEnvList pte things + +loadDecls :: Bool + -> [(Fingerprint, IfaceDecl)] + -> IfL [(Name,TyThing)] +loadDecls ignore_prags ver_decls + = do { thingss <- mapM (loadDecl ignore_prags) ver_decls + ; return (concat thingss) + } + +loadDecl :: Bool -- Don't load pragmas into the decl pool + -> (Fingerprint, IfaceDecl) + -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the + -- TyThings are forkM'd thunks +loadDecl ignore_prags (_version, decl) + = do { -- Populate the name cache with final versions of all + -- the names associated with the decl + let main_name = ifName decl + + -- Typecheck the thing, lazily + -- NB. Firstly, the laziness is there in case we never need the + -- declaration (in one-shot mode), and secondly it is there so that + -- we don't look up the occurrence of a name before calling mk_new_bndr + -- on the binder. This is important because we must get the right name + -- which includes its nameParent. + + ; thing <- forkM doc $ do { bumpDeclStats main_name + ; tcIfaceDecl ignore_prags decl } + + -- Populate the type environment with the implicitTyThings too. + -- + -- Note [Tricky iface loop] + -- ~~~~~~~~~~~~~~~~~~~~~~~~ + -- Summary: The delicate point here is that 'mini-env' must be + -- buildable from 'thing' without demanding any of the things + -- 'forkM'd by tcIfaceDecl. + -- + -- In more detail: Consider the example + -- data T a = MkT { x :: T a } + -- The implicitTyThings of T are: [ <datacon MkT>, <selector x>] + -- (plus their workers, wrappers, coercions etc etc) + -- + -- We want to return an environment + -- [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ] + -- (where the "MkT" is the *Name* associated with MkT, etc.) + -- + -- We do this by mapping the implicit_names to the associated + -- TyThings. By the invariant on ifaceDeclImplicitBndrs and + -- implicitTyThings, we can use getOccName on the implicit + -- TyThings to make this association: each Name's OccName should + -- be the OccName of exactly one implicitTyThing. So the key is + -- to define a "mini-env" + -- + -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ] + -- where the 'MkT' here is the *OccName* associated with MkT. + -- + -- However, there is a subtlety: due to how type checking needs + -- to be staged, we can't poke on the forkM'd thunks inside the + -- implicitTyThings while building this mini-env. + -- If we poke these thunks too early, two problems could happen: + -- (1) When processing mutually recursive modules across + -- hs-boot boundaries, poking too early will do the + -- type-checking before the recursive knot has been tied, + -- so things will be type-checked in the wrong + -- environment, and necessary variables won't be in + -- scope. + -- + -- (2) Looking up one OccName in the mini_env will cause + -- others to be looked up, which might cause that + -- original one to be looked up again, and hence loop. + -- + -- The code below works because of the following invariant: + -- getOccName on a TyThing does not force the suspended type + -- checks in order to extract the name. For example, we don't + -- poke on the "T a" type of <selector x> on the way to + -- extracting <selector x>'s OccName. Of course, there is no + -- reason in principle why getting the OccName should force the + -- thunks, but this means we need to be careful in + -- implicitTyThings and its helper functions. + -- + -- All a bit too finely-balanced for my liking. + + -- This mini-env and lookup function mediates between the + --'Name's n and the map from 'OccName's to the implicit TyThings + ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing] + lookup n = case lookupOccEnv mini_env (getOccName n) of + Just thing -> thing + Nothing -> + pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl)) + + ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) + +-- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) + ; return $ (main_name, thing) : + -- uses the invariant that implicit_names and + -- implicitTyThings are bijective + [(n, lookup n) | n <- implicit_names] + } + where + doc = text "Declaration for" <+> ppr (ifName decl) + +bumpDeclStats :: Name -> IfL () -- Record that one more declaration has actually been used +bumpDeclStats name + = do { traceIf (text "Loading decl for" <+> ppr name) + ; updateEps_ (\eps -> let stats = eps_stats eps + in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) + } + +{- +********************************************************* +* * +\subsection{Reading an interface file} +* * +********************************************************* + +Note [Home module load error] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the sought-for interface is in the current package (as determined +by -package-name flag) then it jolly well should already be in the HPT +because we process home-package modules in dependency order. (Except +in one-shot mode; see notes with hsc_HPT decl in HscTypes). + +It is possible (though hard) to get this error through user behaviour. + * Suppose package P (modules P1, P2) depends on package Q (modules Q1, + Q2, with Q2 importing Q1) + * We compile both packages. + * Now we edit package Q so that it somehow depends on P + * Now recompile Q with --make (without recompiling P). + * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2 + is a home-package module which is not yet in the HPT! Disaster. + +This actually happened with P=base, Q=ghc-prim, via the AMP warnings. +See #8320. +-} + +findAndReadIface :: SDoc + -- The unique identifier of the on-disk module we're + -- looking for + -> InstalledModule + -- The *actual* module we're looking for. We use + -- this to check the consistency of the requirements + -- of the module we read out. + -> Module + -> IsBootInterface -- True <=> Look for a .hi-boot file + -- False <=> Look for .hi file + -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -- Nothing <=> file not found, or unreadable, or illegible + -- Just x <=> successfully found and parsed + + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface +findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file + = do traceIf (sep [hsep [text "Reading", + if hi_boot_file + then text "[boot]" + else Outputable.empty, + text "interface for", + ppr mod <> semi], + nest 4 (text "reason:" <+> doc_str)]) + + -- Check for GHC.Prim, and return its static interface + -- TODO: make this check a function + if mod `installedModuleEq` gHC_PRIM + then do + iface <- getHooked ghcPrimIfaceHook ghcPrimIface + return (Succeeded (iface, + "<built in interface for GHC.Prim>")) + else do + dflags <- getDynFlags + -- Look for the file + hsc_env <- getTopEnv + mb_found <- liftIO (findExactModule hsc_env mod) + case mb_found of + InstalledFound loc mod -> do + -- Found file, so read it + let file_path = addBootSuffix_maybe hi_boot_file + (ml_hi_file loc) + + -- See Note [Home module load error] + if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags && + not (isOneShot (ghcMode dflags)) + then return (Failed (homeModError mod loc)) + else do r <- read_file file_path + checkBuildDynamicToo r + return r + err -> do + traceIf (text "...not found") + dflags <- getDynFlags + return (Failed (cannotFindInterface dflags + (installedModuleName mod) err)) + where read_file file_path = do + traceIf (text "readIFace" <+> text file_path) + -- Figure out what is recorded in mi_module. If this is + -- a fully definite interface, it'll match exactly, but + -- if it's indefinite, the inside will be uninstantiated! + dflags <- getDynFlags + let wanted_mod = + case splitModuleInsts wanted_mod_with_insts of + (_, Nothing) -> wanted_mod_with_insts + (_, Just indef_mod) -> + indefModuleToModule dflags + (generalizeIndefModule indef_mod) + read_result <- readIface wanted_mod file_path + case read_result of + Failed err -> return (Failed (badIfaceFile file_path err)) + Succeeded iface -> return (Succeeded (iface, file_path)) + -- Don't forget to fill in the package name... + checkBuildDynamicToo (Succeeded (iface, filePath)) = do + dflags <- getDynFlags + -- Indefinite interfaces are ALWAYS non-dynamic, and + -- that's OK. + let is_definite_iface = moduleIsDefinite (mi_module iface) + when is_definite_iface $ + whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do + let ref = canGenerateDynamicToo dflags + dynFilePath = addBootSuffix_maybe hi_boot_file + $ replaceExtension filePath (dynHiSuf dflags) + r <- read_file dynFilePath + case r of + Succeeded (dynIface, _) + | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) -> + return () + | otherwise -> + do traceIf (text "Dynamic hash doesn't match") + liftIO $ writeIORef ref False + Failed err -> + do traceIf (text "Failed to load dynamic interface file:" $$ err) + liftIO $ writeIORef ref False + checkBuildDynamicToo _ = return () + +-- @readIface@ tries just the one file. + +readIface :: Module -> FilePath + -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) + -- Failed err <=> file not found, or unreadable, or illegible + -- Succeeded iface <=> successfully found and parsed + +readIface wanted_mod file_path + = do { res <- tryMostM $ + readBinIface CheckHiWay QuietBinIFaceReading file_path + ; dflags <- getDynFlags + ; case res of + Right iface + -- NB: This check is NOT just a sanity check, it is + -- critical for correctness of recompilation checking + -- (it lets us tell when -this-unit-id has changed.) + | wanted_mod == actual_mod + -> return (Succeeded iface) + | otherwise -> return (Failed err) + where + actual_mod = mi_module iface + err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod + + Left exn -> return (Failed (text (showException exn))) + } + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +initExternalPackageState :: ExternalPackageState +initExternalPackageState + = EPS { + eps_is_boot = emptyUFM, + eps_PIT = emptyPackageIfaceTable, + eps_free_holes = emptyInstalledModuleEnv, + eps_PTE = emptyTypeEnv, + eps_inst_env = emptyInstEnv, + eps_fam_inst_env = emptyFamInstEnv, + eps_rule_base = mkRuleBase builtinRules, + -- Initialise the EPS rule pool with the built-in rules + eps_mod_fam_inst_env + = emptyModuleEnv, + eps_complete_matches = emptyUFM, + eps_ann_env = emptyAnnEnv, + eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 + , n_insts_in = 0, n_insts_out = 0 + , n_rules_in = length builtinRules, n_rules_out = 0 } + } + +{- +********************************************************* +* * + Wired-in interface for GHC.Prim +* * +********************************************************* +-} + +ghcPrimIface :: ModIface +ghcPrimIface + = empty_iface { + mi_exports = ghcPrimExports, + mi_decls = [], + mi_fixities = fixities, + mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities } + } + where + empty_iface = emptyFullModIface gHC_PRIM + + -- The fixities listed here for @`seq`@ or @->@ should match + -- those in primops.txt.pp (from which Haddock docs are generated). + fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR) + : (occName funTyConName, funTyFixity) -- trac #10145 + : mapMaybe mkFixity allThePrimOps + mkFixity op = (,) (primOpOcc op) <$> primOpFixity op + +{- +********************************************************* +* * +\subsection{Statistics} +* * +********************************************************* +-} + +ifaceStats :: ExternalPackageState -> SDoc +ifaceStats eps + = hcat [text "Renamer stats: ", msg] + where + stats = eps_stats eps + msg = vcat + [int (n_ifaces_in stats) <+> text "interfaces read", + hsep [ int (n_decls_out stats), text "type/class/variable imported, out of", + int (n_decls_in stats), text "read"], + hsep [ int (n_insts_out stats), text "instance decls imported, out of", + int (n_insts_in stats), text "read"], + hsep [ int (n_rules_out stats), text "rule decls imported, out of", + int (n_rules_in stats), text "read"] + ] + +{- +************************************************************************ +* * + Printing interfaces +* * +************************************************************************ + +Note [Name qualification with --show-iface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In order to disambiguate between identifiers from different modules, we qualify +all names that don't originate in the current module. In order to keep visual +noise as low as possible, we keep local names unqualified. + +For some background on this choice see trac #15269. +-} + +-- | Read binary interface, and print it out +showIface :: HscEnv -> FilePath -> IO () +showIface hsc_env filename = do + -- skip the hi way check; we don't want to worry about profiled vs. + -- non-profiled interfaces, for example. + iface <- initTcRnIf 's' hsc_env () () $ + readBinIface IgnoreHiWay TraceBinIFaceReading filename + let dflags = hsc_dflags hsc_env + -- See Note [Name qualification with --show-iface] + qualifyImportedNames mod _ + | mod == mi_module iface = NameUnqual + | otherwise = NameNotInScope1 + print_unqual = QueryQualify qualifyImportedNames + neverQualifyModules + neverQualifyPackages + putLogMsg dflags NoReason SevDump noSrcSpan + (mkDumpStyle dflags print_unqual) (pprModIface iface) + +-- Show a ModIface but don't display details; suitable for ModIfaces stored in +-- the EPT. +pprModIfaceSimple :: ModIface -> SDoc +pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface))) + +pprModIface :: ModIface -> SDoc +-- Show a ModIface +pprModIface iface@ModIface{ mi_final_exts = exts } + = vcat [ text "interface" + <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface) + <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty) + <+> (if mi_finsts exts then text "[family instance module]" else Outputable.empty) + <+> (if mi_hpc iface then text "[hpc]" else Outputable.empty) + <+> integer hiVersion + , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash exts)) + , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash exts)) + , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash exts)) + , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash exts)) + , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash exts)) + , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash exts)) + , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash exts)) + , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash exts)) + , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface)) + , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) + , nest 2 (text "where") + , text "exports:" + , nest 2 (vcat (map pprExport (mi_exports iface))) + , pprDeps (mi_deps iface) + , vcat (map pprUsage (mi_usages iface)) + , vcat (map pprIfaceAnnotation (mi_anns iface)) + , pprFixities (mi_fixities iface) + , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] + , vcat (map ppr (mi_insts iface)) + , vcat (map ppr (mi_fam_insts iface)) + , vcat (map ppr (mi_rules iface)) + , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) + , vcat (map ppr (mi_complete_sigs iface)) + , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface)) + , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface)) + , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface)) + ] + where + pp_hsc_src HsBootFile = text "[boot]" + pp_hsc_src HsigFile = text "[hsig]" + pp_hsc_src HsSrcFile = Outputable.empty + +{- +When printing export lists, we print like this: + Avail f f + AvailTC C [C, x, y] C(x,y) + AvailTC C [x, y] C!(x,y) -- Exporting x, y but not C +-} + +pprExport :: IfaceExport -> SDoc +pprExport (Avail n) = ppr n +pprExport (AvailTC _ [] []) = Outputable.empty +pprExport (AvailTC n ns0 fs) + = case ns0 of + (n':ns) | n==n' -> ppr n <> pp_export ns fs + _ -> ppr n <> vbar <> pp_export ns0 fs + where + pp_export [] [] = Outputable.empty + pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs)) + +pprUsage :: Usage -> SDoc +pprUsage usage@UsagePackageModule{} + = pprUsageImport usage usg_mod +pprUsage usage@UsageHomeModule{} + = pprUsageImport usage usg_mod_name $$ + nest 2 ( + maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ + vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] + ) +pprUsage usage@UsageFile{} + = hsep [text "addDependentFile", + doubleQuotes (text (usg_file_path usage)), + ppr (usg_file_hash usage)] +pprUsage usage@UsageMergedRequirement{} + = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)] + +pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc +pprUsageImport usage usg_mod' + = hsep [text "import", safe, ppr (usg_mod' usage), + ppr (usg_mod_hash usage)] + where + safe | usg_safe usage = text "safe" + | otherwise = text " -/ " + +pprDeps :: Dependencies -> SDoc +pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, + dep_finsts = finsts }) + = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods), + text "package dependencies:" <+> fsep (map ppr_pkg pkgs), + text "orphans:" <+> fsep (map ppr orphs), + text "family instance modules:" <+> fsep (map ppr finsts) + ] + where + ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot + ppr_pkg (pkg,trust_req) = ppr pkg <> + (if trust_req then text "*" else Outputable.empty) + ppr_boot True = text "[boot]" + ppr_boot False = Outputable.empty + +pprFixities :: [(OccName, Fixity)] -> SDoc +pprFixities [] = Outputable.empty +pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes + where + pprFix (occ,fix) = ppr fix <+> ppr occ + +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = text "trusted:" <+> ppr trust + +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg + +instance Outputable Warnings where + ppr = pprWarns + +pprWarns :: Warnings -> SDoc +pprWarns NoWarnings = Outputable.empty +pprWarns (WarnAll txt) = text "Warn all" <+> ppr txt +pprWarns (WarnSome prs) = text "Warnings" + <+> vcat (map pprWarning prs) + where pprWarning (name, txt) = ppr name <+> ppr txt + +pprIfaceAnnotation :: IfaceAnnotation -> SDoc +pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized }) + = ppr target <+> text "annotated by" <+> ppr serialized + +{- +********************************************************* +* * +\subsection{Errors} +* * +********************************************************* +-} + +badIfaceFile :: String -> SDoc -> SDoc +badIfaceFile file err + = vcat [text "Bad interface file:" <+> text file, + nest 4 err] + +hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc +hiModuleNameMismatchWarn dflags requested_mod read_mod + | moduleUnitId requested_mod == moduleUnitId read_mod = + sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, + text "but we were expecting module" <+> quotes (ppr requested_mod), + sep [text "Probable cause: the source code which generated interface file", + text "has an incompatible module name" + ] + ] + | otherwise = + -- ToDo: This will fail to have enough qualification when the package IDs + -- are the same + withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ + -- we want the Modules below to be qualified with package names, + -- so reset the PrintUnqualified setting. + hsep [ text "Something is amiss; requested module " + , ppr requested_mod + , text "differs from name found in the interface file" + , ppr read_mod + , parens (text "if these names look the same, try again with -dppr-debug") + ] + +homeModError :: InstalledModule -> ModLocation -> SDoc +-- See Note [Home module load error] +homeModError mod location + = text "attempting to use module " <> quotes (ppr mod) + <> (case ml_hs_file location of + Just file -> space <> parens (text file) + Nothing -> Outputable.empty) + <+> text "which is not loaded" diff --git a/compiler/GHC/Iface/Load.hs-boot b/compiler/GHC/Iface/Load.hs-boot new file mode 100644 index 0000000000..e3dce1d68f --- /dev/null +++ b/compiler/GHC/Iface/Load.hs-boot @@ -0,0 +1,8 @@ +module GHC.Iface.Load where + +import Module (Module) +import TcRnMonad (IfM) +import HscTypes (ModIface) +import Outputable (SDoc) + +loadSysInterface :: SDoc -> Module -> IfM lcl ModIface diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs new file mode 100644 index 0000000000..94a7dbc06e --- /dev/null +++ b/compiler/GHC/Iface/Rename.hs @@ -0,0 +1,743 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +-- | This module implements interface renaming, which is +-- used to rewrite interface files on the fly when we +-- are doing indefinite typechecking and need instantiations +-- of modules which do not necessarily exist yet. + +module GHC.Iface.Rename ( + rnModIface, + rnModExports, + tcRnModIface, + tcRnModExports, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import SrcLoc +import Outputable +import HscTypes +import Module +import UniqFM +import Avail +import GHC.Iface.Syntax +import FieldLabel +import Var +import ErrUtils + +import Name +import TcRnMonad +import Util +import Fingerprint +import BasicTypes + +-- a bit vexing +import {-# SOURCE #-} GHC.Iface.Load +import DynFlags + +import qualified Data.Traversable as T + +import Bag +import Data.IORef +import NameShape +import GHC.Iface.Env + +tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a +tcRnMsgMaybe do_this = do + r <- liftIO $ do_this + case r of + Left errs -> do + addMessages (emptyBag, errs) + failM + Right x -> return x + +tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface +tcRnModIface x y z = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModIface hsc_env x y z + +tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo] +tcRnModExports x y = do + hsc_env <- getTopEnv + tcRnMsgMaybe $ rnModExports hsc_env x y + +failWithRn :: SDoc -> ShIfM a +failWithRn doc = do + errs_var <- fmap sh_if_errs getGblEnv + dflags <- getDynFlags + errs <- readTcRef errs_var + -- TODO: maybe associate this with a source location? + writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc) + failM + +-- | What we have is a generalized ModIface, which corresponds to +-- a module that looks like p[A=<A>]:B. We need a *specific* ModIface, e.g. +-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load +-- up (either to merge it, or to just use during typechecking). +-- +-- Suppose we have: +-- +-- p[A=<A>]:M ==> p[A=q():A]:M +-- +-- Substitute all occurrences of <A> with q():A (renameHoleModule). +-- Then, for any Name of form {A.T}, replace the Name with +-- the Name according to the exports of the implementing module. +-- This works even for p[A=<B>]:M, since we just read in the +-- exports of B.hi, which is assumed to be ready now. +-- +-- This function takes an optional 'NameShape', which can be used +-- to further refine the identities in this interface: suppose +-- we read a declaration for {H.T} but we actually know that this +-- should be Foo.T; then we'll also rename this (this is used +-- when loading an interface to merge it into a requirement.) +rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape + -> ModIface -> IO (Either ErrorMessages ModIface) +rnModIface hsc_env insts nsubst iface = do + initRnIface hsc_env iface insts nsubst $ do + mod <- rnModule (mi_module iface) + sig_of <- case mi_sig_of iface of + Nothing -> return Nothing + Just x -> fmap Just (rnModule x) + exports <- mapM rnAvailInfo (mi_exports iface) + decls <- mapM rnIfaceDecl' (mi_decls iface) + insts <- mapM rnIfaceClsInst (mi_insts iface) + fams <- mapM rnIfaceFamInst (mi_fam_insts iface) + deps <- rnDependencies (mi_deps iface) + -- TODO: + -- mi_rules + return iface { mi_module = mod + , mi_sig_of = sig_of + , mi_insts = insts + , mi_fam_insts = fams + , mi_exports = exports + , mi_decls = decls + , mi_deps = deps } + +-- | Rename just the exports of a 'ModIface'. Useful when we're doing +-- shaping prior to signature merging. +rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo]) +rnModExports hsc_env insts iface + = initRnIface hsc_env iface insts Nothing + $ mapM rnAvailInfo (mi_exports iface) + +rnDependencies :: Rename Dependencies +rnDependencies deps = do + orphs <- rnDepModules dep_orphs deps + finsts <- rnDepModules dep_finsts deps + return deps { dep_orphs = orphs, dep_finsts = finsts } + +rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module] +rnDepModules sel deps = do + hsc_env <- getTopEnv + hmap <- getHoleSubst + -- NB: It's not necessary to test if we're doing signature renaming, + -- because ModIface will never contain module reference for itself + -- in these dependencies. + fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do + dflags <- getDynFlags + -- For holes, its necessary to "see through" the instantiation + -- of the hole to get accurate family instance dependencies. + -- For example, if B imports <A>, and <A> is instantiated with + -- F, we must grab and include all of the dep_finsts from + -- F to have an accurate transitive dep_finsts list. + -- + -- However, we MUST NOT do this for regular modules. + -- First, for efficiency reasons, doing this + -- bloats the the dep_finsts list, because we *already* had + -- those modules in the list (it wasn't a hole module, after + -- all). But there's a second, more important correctness + -- consideration: we perform module renaming when running + -- --abi-hash. In this case, GHC's contract to the user is that + -- it will NOT go and read out interfaces of any dependencies + -- (https://github.com/haskell/cabal/issues/3633); the point of + -- --abi-hash is just to get a hash of the on-disk interfaces + -- for this *specific* package. If we go off and tug on the + -- interface for /everything/ in dep_finsts, we're gonna have a + -- bad time. (It's safe to do do this for hole modules, though, + -- because the hmap for --abi-hash is always trivial, so the + -- interface we request is local. Though, maybe we ought + -- not to do it in this case either...) + -- + -- This mistake was bug #15594. + let mod' = renameHoleModule dflags hmap mod + if isHoleModule mod + then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env + $ loadSysInterface (text "rnDepModule") mod' + return (mod' : sel (mi_deps iface)) + else return [mod'] + +{- +************************************************************************ +* * + ModIface substitution +* * +************************************************************************ +-} + +-- | Run a computation in the 'ShIfM' monad. +initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape + -> ShIfM a -> IO (Either ErrorMessages a) +initRnIface hsc_env iface insts nsubst do_this = do + errs_var <- newIORef emptyBag + let dflags = hsc_dflags hsc_env + hsubst = listToUFM insts + rn_mod = renameHoleModule dflags hsubst + env = ShIfEnv { + sh_if_module = rn_mod (mi_module iface), + sh_if_semantic_module = rn_mod (mi_semantic_module iface), + sh_if_hole_subst = listToUFM insts, + sh_if_shape = nsubst, + sh_if_errs = errs_var + } + -- Modeled off of 'initTc' + res <- initTcRnIf 'c' hsc_env env () $ tryM do_this + msgs <- readIORef errs_var + case res of + Left _ -> return (Left msgs) + Right r | not (isEmptyBag msgs) -> return (Left msgs) + | otherwise -> return (Right r) + +-- | Environment for 'ShIfM' monads. +data ShIfEnv = ShIfEnv { + -- What we are renaming the ModIface to. It assumed that + -- the original mi_module of the ModIface is + -- @generalizeModule (mi_module iface)@. + sh_if_module :: Module, + -- The semantic module that we are renaming to + sh_if_semantic_module :: Module, + -- Cached hole substitution, e.g. + -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@ + sh_if_hole_subst :: ShHoleSubst, + -- An optional name substitution to be applied when renaming + -- the names in the interface. If this is 'Nothing', then + -- we just load the target interface and look at the export + -- list to determine the renaming. + sh_if_shape :: Maybe NameShape, + -- Mutable reference to keep track of errors (similar to 'tcl_errs') + sh_if_errs :: IORef ErrorMessages + } + +getHoleSubst :: ShIfM ShHoleSubst +getHoleSubst = fmap sh_if_hole_subst getGblEnv + +type ShIfM = TcRnIf ShIfEnv () +type Rename a = a -> ShIfM a + + +rnModule :: Rename Module +rnModule mod = do + hmap <- getHoleSubst + dflags <- getDynFlags + return (renameHoleModule dflags hmap mod) + +rnAvailInfo :: Rename AvailInfo +rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n +rnAvailInfo (AvailTC n ns fs) = do + -- Why don't we rnIfaceGlobal the availName itself? It may not + -- actually be exported by the module it putatively is from, in + -- which case we won't be able to tell what the name actually + -- is. But for the availNames they MUST be exported, so they + -- will rename fine. + ns' <- mapM rnIfaceGlobal ns + fs' <- mapM rnFieldLabel fs + case ns' ++ map flSelector fs' of + [] -> panic "rnAvailInfoEmpty AvailInfo" + (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do + n' <- setNameModule (Just (nameModule rep)) n + return (AvailTC n' ns' fs') + +rnFieldLabel :: Rename FieldLabel +rnFieldLabel (FieldLabel l b sel) = do + sel' <- rnIfaceGlobal sel + return (FieldLabel l b sel') + + + + +-- | The key function. This gets called on every Name embedded +-- inside a ModIface. Our job is to take a Name from some +-- generalized unit ID p[A=<A>, B=<B>], and change +-- it to the correct name for a (partially) instantiated unit +-- ID, e.g. p[A=q[]:A, B=<B>]. +-- +-- There are two important things to do: +-- +-- If a hole is substituted with a real module implementation, +-- we need to look at that actual implementation to determine what +-- the true identity of this name should be. We'll do this by +-- loading that module's interface and looking at the mi_exports. +-- +-- However, there is one special exception: when we are loading +-- the interface of a requirement. In this case, we may not have +-- the "implementing" interface, because we are reading this +-- interface precisely to "merge it in". +-- +-- External case: +-- p[A=<B>]:A (and thisUnitId is something else) +-- We are loading this in order to determine B.hi! So +-- don't load B.hi to find the exports. +-- +-- Local case: +-- p[A=<A>]:A (and thisUnitId is p[A=<A>]) +-- This should not happen, because the rename is not necessary +-- in this case, but if it does we shouldn't load A.hi! +-- +-- Compare me with 'tcIfaceGlobal'! + +-- In effect, this function needs compute the name substitution on the +-- fly. What it has is the name that we would like to substitute. +-- If the name is not a hole name {M.x} (e.g. isHoleModule) then +-- no renaming can take place (although the inner hole structure must +-- be updated to account for the hole module renaming.) +rnIfaceGlobal :: Name -> ShIfM Name +rnIfaceGlobal n = do + hsc_env <- getTopEnv + let dflags = hsc_dflags hsc_env + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + mb_nsubst <- fmap sh_if_shape getGblEnv + hmap <- getHoleSubst + let m = nameModule n + m' = renameHoleModule dflags hmap m + case () of + -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so, + -- do NOT assume B.hi is available. + -- In this case, rename {A.T} to {B.T} but don't look up exports. + _ | m' == iface_semantic_mod + , isHoleModule m' + -- NB: this could be Nothing for computeExports, we have + -- nothing to say. + -> do n' <- setNameModule (Just m') n + case mb_nsubst of + Nothing -> return n' + Just nsubst -> + case maybeSubstNameShape nsubst n' of + -- TODO: would love to have context + -- TODO: This will give an unpleasant message if n' + -- is a constructor; then we'll suggest adding T + -- but it won't work. + Nothing -> failWithRn $ vcat [ + text "The identifier" <+> ppr (occName n') <+> + text "does not exist in the local signature.", + parens (text "Try adding it to the export list of the hsig file.") + ] + Just n'' -> return n'' + -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the + -- export list is irrelevant. + | not (isHoleModule m) + -> setNameModule (Just m') n + -- The substitution was from <A> to p[]:A. + -- But this does not mean {A.T} goes to p[]:A.T: + -- p[]:A may reexport T from somewhere else. Do the name + -- substitution. Furthermore, we need + -- to make sure we pick the accurate name NOW, + -- or we might accidentally reject a merge. + | otherwise + -> do -- Make sure we look up the local interface if substitution + -- went from <A> to <B>. + let m'' = if isHoleModule m' + -- Pull out the local guy!! + then mkModule (thisPackage dflags) (moduleName m') + else m' + iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env + $ loadSysInterface (text "rnIfaceGlobal") m'' + let nsubst = mkNameShape (moduleName m) (mi_exports iface) + case maybeSubstNameShape nsubst n of + Nothing -> failWithRn $ vcat [ + text "The identifier" <+> ppr (occName n) <+> + -- NB: report m' because it's more user-friendly + text "does not exist in the signature for" <+> ppr m', + parens (text "Try adding it to the export list in that hsig file.") + ] + Just n' -> return n' + +-- | Rename an implicit name, e.g., a DFun or coercion axiom. +-- Here is where we ensure that DFuns have the correct module as described in +-- Note [rnIfaceNeverExported]. +rnIfaceNeverExported :: Name -> ShIfM Name +rnIfaceNeverExported name = do + hmap <- getHoleSubst + dflags <- getDynFlags + iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv + let m = renameHoleModule dflags hmap $ nameModule name + -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined. + MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m ) + setNameModule (Just m) name + +-- Note [rnIfaceNeverExported] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For the high-level overview, see +-- Note [Handling never-exported TyThings under Backpack] +-- +-- When we see a reference to an entity that was defined in a signature, +-- 'rnIfaceGlobal' relies on the identifier in question being part of the +-- exports of the implementing 'ModIface', so that we can use the exports to +-- decide how to rename the identifier. Unfortunately, references to 'DFun's +-- and 'CoAxiom's will run into trouble under this strategy, because they are +-- never exported. +-- +-- Let us consider first what should happen in the absence of promotion. In +-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside +-- the signature *that is defining it* (as there are no Core terms in +-- typechecked-only interface files, there's no way for a reference to occur +-- besides from the defining 'ClsInst' or closed type family). Thus, +-- it doesn't really matter what names we give the DFun/CoAxiom, as long +-- as it's consistent between the declaration site and the use site. +-- +-- We have to make sure that these bogus names don't get propagated, +-- but it is fine: see Note [Signature merging DFuns] for the fixups +-- to the names we do before writing out the merged interface. +-- (It's even easier for instantiation, since the DFuns all get +-- dropped entirely; the instances are reexported implicitly.) +-- +-- Unfortunately, this strategy is not enough in the presence of promotion +-- (see bug #13149), where modules which import the signature may make +-- reference to their coercions. It's not altogether clear how to +-- fix this case, but it is definitely a bug! + +-- PILES AND PILES OF BOILERPLATE + +-- | Rename an 'IfaceClsInst', with special handling for an associated +-- dictionary function. +rnIfaceClsInst :: Rename IfaceClsInst +rnIfaceClsInst cls_inst = do + n <- rnIfaceGlobal (ifInstCls cls_inst) + tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) + + dfun <- rnIfaceNeverExported (ifDFun cls_inst) + return cls_inst { ifInstCls = n + , ifInstTys = tys + , ifDFun = dfun + } + +rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) +rnMaybeIfaceTyCon Nothing = return Nothing +rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc + +rnIfaceFamInst :: Rename IfaceFamInst +rnIfaceFamInst d = do + fam <- rnIfaceGlobal (ifFamInstFam d) + tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) + axiom <- rnIfaceGlobal (ifFamInstAxiom d) + return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } + +rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) +rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl + +rnIfaceDecl :: Rename IfaceDecl +rnIfaceDecl d@IfaceId{} = do + name <- case ifIdDetails d of + IfDFunId -> rnIfaceNeverExported (ifName d) + _ | isDefaultMethodOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) + -- Typeable bindings. See Note [Grand plan for Typeable]. + _ | isTypeableBindOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) + | otherwise -> rnIfaceGlobal (ifName d) + ty <- rnIfaceType (ifType d) + details <- rnIfaceIdDetails (ifIdDetails d) + info <- rnIfaceIdInfo (ifIdInfo d) + return d { ifName = name + , ifType = ty + , ifIdDetails = details + , ifIdInfo = info + } +rnIfaceDecl d@IfaceData{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + ctxt <- mapM rnIfaceType (ifCtxt d) + cons <- rnIfaceConDecls (ifCons d) + res_kind <- rnIfaceType (ifResKind d) + parent <- rnIfaceTyConParent (ifParent d) + return d { ifName = name + , ifBinders = binders + , ifCtxt = ctxt + , ifCons = cons + , ifResKind = res_kind + , ifParent = parent + } +rnIfaceDecl d@IfaceSynonym{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + syn_kind <- rnIfaceType (ifResKind d) + syn_rhs <- rnIfaceType (ifSynRhs d) + return d { ifName = name + , ifBinders = binders + , ifResKind = syn_kind + , ifSynRhs = syn_rhs + } +rnIfaceDecl d@IfaceFamily{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + fam_kind <- rnIfaceType (ifResKind d) + fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d) + return d { ifName = name + , ifBinders = binders + , ifResKind = fam_kind + , ifFamFlav = fam_flav + } +rnIfaceDecl d@IfaceClass{} = do + name <- rnIfaceGlobal (ifName d) + binders <- mapM rnIfaceTyConBinder (ifBinders d) + body <- rnIfaceClassBody (ifBody d) + return d { ifName = name + , ifBinders = binders + , ifBody = body + } +rnIfaceDecl d@IfaceAxiom{} = do + name <- rnIfaceNeverExported (ifName d) + tycon <- rnIfaceTyCon (ifTyCon d) + ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d) + return d { ifName = name + , ifTyCon = tycon + , ifAxBranches = ax_branches + } +rnIfaceDecl d@IfacePatSyn{} = do + name <- rnIfaceGlobal (ifName d) + let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b + pat_matcher <- rnPat (ifPatMatcher d) + pat_builder <- T.traverse rnPat (ifPatBuilder d) + pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d) + pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d) + pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d) + pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d) + pat_args <- mapM rnIfaceType (ifPatArgs d) + pat_ty <- rnIfaceType (ifPatTy d) + return d { ifName = name + , ifPatMatcher = pat_matcher + , ifPatBuilder = pat_builder + , ifPatUnivBndrs = pat_univ_bndrs + , ifPatExBndrs = pat_ex_bndrs + , ifPatProvCtxt = pat_prov_ctxt + , ifPatReqCtxt = pat_req_ctxt + , ifPatArgs = pat_args + , ifPatTy = pat_ty + } + +rnIfaceClassBody :: Rename IfaceClassBody +rnIfaceClassBody IfAbstractClass = return IfAbstractClass +rnIfaceClassBody d@IfConcreteClass{} = do + ctxt <- mapM rnIfaceType (ifClassCtxt d) + ats <- mapM rnIfaceAT (ifATs d) + sigs <- mapM rnIfaceClassOp (ifSigs d) + return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs } + +rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav +rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs))) + = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n + <*> mapM rnIfaceAxBranch axs) +rnIfaceFamTyConFlav flav = pure flav + +rnIfaceAT :: Rename IfaceAT +rnIfaceAT (IfaceAT decl mb_ty) + = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty + +rnIfaceTyConParent :: Rename IfaceTyConParent +rnIfaceTyConParent (IfDataInstance n tc args) + = IfDataInstance <$> rnIfaceGlobal n + <*> rnIfaceTyCon tc + <*> rnIfaceAppArgs args +rnIfaceTyConParent IfNoParent = pure IfNoParent + +rnIfaceConDecls :: Rename IfaceConDecls +rnIfaceConDecls (IfDataTyCon ds) + = IfDataTyCon <$> mapM rnIfaceConDecl ds +rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d +rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon + +rnIfaceConDecl :: Rename IfaceConDecl +rnIfaceConDecl d = do + con_name <- rnIfaceGlobal (ifConName d) + con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d) + con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d) + let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t + con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d) + con_ctxt <- mapM rnIfaceType (ifConCtxt d) + con_arg_tys <- mapM rnIfaceType (ifConArgTys d) + con_fields <- mapM rnFieldLabel (ifConFields d) + let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co + rnIfaceBang bang = pure bang + con_stricts <- mapM rnIfaceBang (ifConStricts d) + return d { ifConName = con_name + , ifConExTCvs = con_ex_tvs + , ifConUserTvBinders = con_user_tvbs + , ifConEqSpec = con_eq_spec + , ifConCtxt = con_ctxt + , ifConArgTys = con_arg_tys + , ifConFields = con_fields + , ifConStricts = con_stricts + } + +rnIfaceClassOp :: Rename IfaceClassOp +rnIfaceClassOp (IfaceClassOp n ty dm) = + IfaceClassOp <$> rnIfaceGlobal n + <*> rnIfaceType ty + <*> rnMaybeDefMethSpec dm + +rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType)) +rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty +rnMaybeDefMethSpec mb = return mb + +rnIfaceAxBranch :: Rename IfaceAxBranch +rnIfaceAxBranch d = do + ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d) + lhs <- rnIfaceAppArgs (ifaxbLHS d) + rhs <- rnIfaceType (ifaxbRHS d) + return d { ifaxbTyVars = ty_vars + , ifaxbLHS = lhs + , ifaxbRHS = rhs } + +rnIfaceIdInfo :: Rename IfaceIdInfo +rnIfaceIdInfo NoInfo = pure NoInfo +rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is + +rnIfaceInfoItem :: Rename IfaceInfoItem +rnIfaceInfoItem (HsUnfold lb if_unf) + = HsUnfold lb <$> rnIfaceUnfolding if_unf +rnIfaceInfoItem i + = pure i + +rnIfaceUnfolding :: Rename IfaceUnfolding +rnIfaceUnfolding (IfCoreUnfold stable if_expr) + = IfCoreUnfold stable <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfCompulsory if_expr) + = IfCompulsory <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr) + = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr +rnIfaceUnfolding (IfDFunUnfold bs ops) + = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops + +rnIfaceExpr :: Rename IfaceExpr +rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name) +rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl +rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty +rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co +rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args +rnIfaceExpr (IfaceLam lam_bndr expr) + = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr +rnIfaceExpr (IfaceApp fun arg) + = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg +rnIfaceExpr (IfaceCase scrut case_bndr alts) + = IfaceCase <$> rnIfaceExpr scrut + <*> pure case_bndr + <*> mapM rnIfaceAlt alts +rnIfaceExpr (IfaceECase scrut ty) + = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty +rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceLet (IfaceRec pairs) body) + = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) -> + (,) <$> rnIfaceLetBndr bndr + <*> rnIfaceExpr rhs) pairs) + <*> rnIfaceExpr body +rnIfaceExpr (IfaceCast expr co) + = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co +rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit) +rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty +rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr + +rnIfaceBndrs :: Rename [IfaceBndr] +rnIfaceBndrs = mapM rnIfaceBndr + +rnIfaceBndr :: Rename IfaceBndr +rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty) +rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr + +rnIfaceTvBndr :: Rename IfaceTvBndr +rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind + +rnIfaceTyConBinder :: Rename IfaceTyConBinder +rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis + +rnIfaceAlt :: Rename IfaceAlt +rnIfaceAlt (conalt, names, rhs) + = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs + +rnIfaceConAlt :: Rename IfaceConAlt +rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ +rnIfaceConAlt alt = pure alt + +rnIfaceLetBndr :: Rename IfaceLetBndr +rnIfaceLetBndr (IfLetBndr fs ty info jpi) + = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi + +rnIfaceLamBndr :: Rename IfaceLamBndr +rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot + +rnIfaceMCo :: Rename IfaceMCoercion +rnIfaceMCo IfaceMRefl = pure IfaceMRefl +rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co + +rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty +rnIfaceCo (IfaceGReflCo role ty mco) + = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco +rnIfaceCo (IfaceFunCo role co1 co2) + = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceTyConAppCo role tc cos) + = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos +rnIfaceCo (IfaceAppCo co1 co2) + = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceForAllCo bndr co1 co2) + = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2 +rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c) +rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl +rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl +rnIfaceCo (IfaceAxiomInstCo n i cs) + = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs +rnIfaceCo (IfaceUnivCo s r t1 t2) + = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceCo (IfaceSymCo c) + = IfaceSymCo <$> rnIfaceCo c +rnIfaceCo (IfaceTransCo c1 c2) + = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceInstCo c1 c2) + = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 +rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c +rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c +rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c +rnIfaceCo (IfaceAxiomRuleCo ax cos) + = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos +rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c + +rnIfaceTyCon :: Rename IfaceTyCon +rnIfaceTyCon (IfaceTyCon n info) + = IfaceTyCon <$> rnIfaceGlobal n <*> pure info + +rnIfaceExprs :: Rename [IfaceExpr] +rnIfaceExprs = mapM rnIfaceExpr + +rnIfaceIdDetails :: Rename IfaceIdDetails +rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b +rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b +rnIfaceIdDetails details = pure details + +rnIfaceType :: Rename IfaceType +rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n) +rnIfaceType (IfaceTyVar n) = pure (IfaceTyVar n) +rnIfaceType (IfaceAppTy t1 t2) + = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2 +rnIfaceType (IfaceLitTy l) = return (IfaceLitTy l) +rnIfaceType (IfaceFunTy af t1 t2) + = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2 +rnIfaceType (IfaceTupleTy s i tks) + = IfaceTupleTy s i <$> rnIfaceAppArgs tks +rnIfaceType (IfaceTyConApp tc tks) + = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks +rnIfaceType (IfaceForAllTy tv t) + = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t +rnIfaceType (IfaceCoercionTy co) + = IfaceCoercionTy <$> rnIfaceCo co +rnIfaceType (IfaceCastTy ty co) + = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co + +rnIfaceForAllBndr :: Rename IfaceForAllBndr +rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis + +rnIfaceAppArgs :: Rename IfaceAppArgs +rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a + <*> rnIfaceAppArgs ts +rnIfaceAppArgs IA_Nil = pure IA_Nil diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs new file mode 100644 index 0000000000..723401cb7e --- /dev/null +++ b/compiler/GHC/Iface/Syntax.hs @@ -0,0 +1,2593 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} + +module GHC.Iface.Syntax ( + module GHC.Iface.Type, + + IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, + IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClassBody(..), + IfaceBang(..), + IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), + IfaceAxBranch(..), + IfaceTyConParent(..), + IfaceCompleteMatch(..), + + -- * Binding names + IfaceTopBndr, + putIfaceTopBndr, getIfaceTopBndr, + + -- Misc + ifaceDeclImplicitBndrs, visibleIfConDecls, + ifaceDeclFingerprints, + + -- Free Names + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + + -- Pretty printing + pprIfaceExpr, + pprIfaceDecl, + AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Iface.Type +import BinFingerprint +import CoreSyn( IsOrphan, isOrphan ) +import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) ) +import Demand +import Class +import FieldLabel +import NameSet +import CoAxiom ( BranchIndex ) +import Name +import CostCentre +import Literal +import ForeignCall +import Annotations( AnnPayload, AnnTarget ) +import BasicTypes +import Outputable +import Module +import SrcLoc +import Fingerprint +import Binary +import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) +import Var( VarBndr(..), binderVar ) +import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +import Util( dropList, filterByList, notNull, unzipWith, debugIsOn ) +import DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import Lexeme (isLexSym) +import TysWiredIn ( constraintKindTyConName ) +import Util (seqList) + +import Control.Monad +import System.IO.Unsafe +import Control.DeepSeq + +infixl 3 &&& + +{- +************************************************************************ +* * + Declarations +* * +************************************************************************ +-} + +-- | A binding top-level 'Name' in an interface file (e.g. the name of an +-- 'IfaceDecl'). +type IfaceTopBndr = Name + -- It's convenient to have a Name in the Iface syntax, although in each + -- case the namespace is implied by the context. However, having a + -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. Moreover, having the key of the binder means that + -- we can encode known-key things cleverly in the symbol table. See Note + -- [Symbol table representation of Names] + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + +getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr +getIfaceTopBndr bh = get bh + +putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () +putIfaceTopBndr bh name = + case getUserData bh of + UserData{ ud_put_binding_name = put_binding_name } -> + --pprTrace "putIfaceTopBndr" (ppr name) $ + put_binding_name bh name + +data IfaceDecl + = IfaceId { ifName :: IfaceTopBndr, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceType, -- Result kind of type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI + ifRoles :: [Role], -- Roles + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data/data family info + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance + } + + | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *result* + ifSynRhs :: IfaceType } + + | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor + ifResVar :: Maybe IfLclName, -- Result variable name, used + -- only for pretty-printing + -- with --show-iface + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *tycon* + ifFamFlav :: IfaceFamTyConFlav, + ifFamInj :: Injectivity } -- injectivity information + + | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifFDs :: [FunDep IfLclName], -- Functional dependencies + ifBody :: IfaceClassBody -- Methods, superclasses, ATs + } + + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name + ifTyCon :: IfaceTyCon, -- LHS TyCon + ifRole :: Role, -- Role of axiom + ifAxBranches :: [IfaceAxBranch] -- Branches + } + + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym + ifPatIsInfix :: Bool, + ifPatMatcher :: (IfExtName, Bool), + ifPatBuilder :: Maybe (IfExtName, Bool), + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl + ifPatUnivBndrs :: [IfaceForAllBndr], + ifPatExBndrs :: [IfaceForAllBndr], + ifPatProvCtxt :: IfaceContext, + ifPatReqCtxt :: IfaceContext, + ifPatArgs :: [IfaceType], + ifPatTy :: IfaceType, + ifFieldLabels :: [FieldLabel] } + +-- See also 'ClassBody' +data IfaceClassBody + -- Abstract classes don't specify their body; they only occur in @hs-boot@ and + -- @hsig@ files. + = IfAbstractClass + | IfConcreteClass { + ifClassCtxt :: IfaceContext, -- Super classes + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition + } + +data IfaceTyConParent + = IfNoParent + | IfDataInstance + IfExtName -- Axiom name + IfaceTyCon -- Family TyCon (pretty-printing only, not used in GHC.IfaceToCore) + -- see Note [Pretty printing via Iface syntax] in PprTyThing + IfaceAppArgs -- Arguments of the family TyCon + +data IfaceFamTyConFlav + = IfaceDataFamilyTyCon -- Data family + | IfaceOpenSynFamilyTyCon + | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) + -- ^ Name of associated axiom and branches for pretty printing purposes, + -- or 'Nothing' for an empty closed family without an axiom + -- See Note [Pretty printing via Iface syntax] in PprTyThing + | IfaceAbstractClosedSynFamilyTyCon + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only + +data IfaceClassOp + = IfaceClassOp IfaceTopBndr + IfaceType -- Class op type + (Maybe (DefMethSpec IfaceType)) -- Default method + -- The types of both the class op itself, + -- and the default method, are *not* quantified + -- over the class variables + +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + + +-- This is just like CoAxBranch +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbEtaTyVars :: [IfaceTvBndr] + , ifaxbCoVars :: [IfaceIdBndr] + , ifaxbLHS :: IfaceAppArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } + -- See Note [Storing compatibility] in CoAxiom + +data IfaceConDecls + = IfAbstractTyCon -- c.f TyCon.AbstractTyCon + | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfNewTyCon IfaceConDecl -- Newtype decls + +-- For IfDataTyCon and IfNewTyCon we store: +-- * the data constructor(s); +-- The field labels are stored individually in the IfaceConDecl +-- (there is some redundancy here, because a field label may occur +-- in multiple IfaceConDecls and represent the same field label) + +data IfaceConDecl + = IfCon { + ifConName :: IfaceTopBndr, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + + ifConExTCvs :: [IfaceBndr], -- Existential ty/covars + ifConUserTvBinders :: [IfaceForAllBndr], + -- The tyvars, in the order the user wrote them + -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the + -- set of tyvars (*not* covars) of ifConExTCvs, unioned + -- with the set of ifBinders (from the parent IfaceDecl) + -- whose tyvars do not appear in ifConEqSpec + -- See Note [DataCon user type variable binders] in DataCon + ifConEqSpec :: IfaceEqSpec, -- Equality constraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [FieldLabel], -- ...ditto... (field labels) + ifConStricts :: [IfaceBang], + -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + -- See Note [Bangs on imported data constructors] in MkId + ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts + +type IfaceEqSpec = [(IfLclName,IfaceType)] + +-- | This corresponds to an HsImplBang; that is, the final +-- implementation decision about the data constructor arg +data IfaceBang + = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion + +-- | This corresponds to HsSrcBang +data IfaceSrcBang + = IfSrcBang SrcUnpackedness SrcStrictness + +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv + -- 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 + +-- The ifFamInstTys field of IfaceFamInst contains a list of the rough +-- match types +data IfaceFamInst + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name + , ifFamInstTys :: [Maybe IfaceTyCon] -- See above + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceRule + = 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 :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: AnnPayload + } + +type IfaceAnnTarget = AnnTarget OccName + +data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName + +instance Outputable IfaceCompleteMatch where + ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls + <+> dcolon <+> ppr ty + + + + +-- 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.) +-- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] + | HsNoCafRefs + | HsLevity -- Present <=> never levity polymorphic + +-- 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 + + | IfDFunUnfold [IfaceBndr] [IfaceExpr] + + +-- 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, because they are not put it +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool + | IfDFunId + +{- +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] + + +************************************************************************ +* * + Functions over declarations +* * +************************************************************************ +-} + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + +ifaceDeclImplicitBndrs :: 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 +-- See Note [Implicit TyThings] in HscTypes + +-- 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 GHC.Iface.Load.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. + +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) + = case cons of + IfAbstractTyCon -> [] + IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd + IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds + +ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) + = [] + +ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name + , ifBody = IfConcreteClass { + ifClassCtxt = sc_ctxt, + ifSigs = sigs, + ifATs = ats + }}) + = -- (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 + [occName (ifName at) | IfaceAT at _ <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [occName op | IfaceClassOp op _ _ <- sigs] + where + cls_tc_occ = occName cls_tc_name + n_ctxt = length sc_ctxt + n_sigs = length sigs + co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] + | otherwise = [] + dcww_occ = mkDataConWorkerOcc dc_occ + dc_occ = mkClassDataConOcc cls_tc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) + +ifaceDeclImplicitBndrs _ = [] + +ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] +ifaceConDeclImplicitBndrs (IfCon { + ifConWrapper = has_wrapper, ifConName = con_name }) + = [occName con_name, work_occ] ++ wrap_occs + where + con_occ = occName con_name + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- The fingerprints of an IfaceDecl + + -- We better give each name bound by the declaration a + -- different fingerprint! So we calculate the fingerprint of + -- each binder by combining the fingerprint of the whole + -- declaration with the name of the binder. (#5614, #7215) +ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] +ifaceDeclFingerprints hash decl + = (getOccName decl, hash) : + [ (occ, computeFingerprint' (hash,occ)) + | occ <- ifaceDeclImplicitBndrs decl ] + where + computeFingerprint' = + unsafeDupablePerformIO + . computeFingerprint (panic "ifaceDeclFingerprints") + +{- +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceLamBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet IfaceBinding IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + | IfaceSource RealSrcSpan String -- from SourceNote + -- no breakpoints: we never export these into 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 IfExtName + | IfaceLitAlt Literal + +data IfaceBinding + = 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 IfaceJoinInfo + +data IfaceJoinInfo = IfaceNotJoinPoint + | IfaceJoinPoint JoinArity + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Iface syntax an IfaceCase does not record the types of the alternatives, +unlike Core syntax Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +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 [Displaying axiom incompatibilities] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With -fprint-axiom-incomps we display which closed type family equations +are incompatible with which. This information is sometimes necessary +because GHC doesn't try equations in order: any equation can be used when +all preceding equations that are incompatible with it do not apply. + +For example, the last "a && a = a" equation in Data.Type.Bool.&& is +actually compatible with all previous equations, and can reduce at any +time. + +This is displayed as: +Prelude> :i Data.Type.Equality.== +type family (==) (a :: k) (b :: k) :: Bool + where + {- #0 -} (==) (f a) (g b) = (f == g) && (a == b) + {- #1 -} (==) a a = 'True + -- incompatible with: #0 + {- #2 -} (==) _1 _2 = 'False + -- incompatible with: #1, #0 +The comment after an equation refers to all previous equations (0-indexed) +that are incompatible with it. + +************************************************************************ +* * + Printing IfaceDecl +* * +************************************************************************ +-} + +pprAxBranch :: SDoc -> BranchIndex -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +-- +-- This function is used +-- to print interface files, +-- in debug messages +-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon +-- For user error messages we use Coercion.pprCoAxiom and friends +pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbCoVars = _cvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = ASSERT2( null _cvs, pp_tc $$ ppr _cvs ) + hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 4 maybe_incomps + where + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + ppr_binders = maybe_index <+> + pprUserIfaceForAll (map (mkIfaceForAllTvBndr Specified) tvs) + pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) + + -- See Note [Displaying axiom incompatibilities] + maybe_index + = sdocWithDynFlags $ \dflags -> + ppWhen (gopt Opt_PrintAxiomIncomps dflags) $ + text "{-" <+> (text "#" <> ppr idx) <+> text "-}" + maybe_incomps + = sdocWithDynFlags $ \dflags -> + ppWhen (gopt Opt_PrintAxiomIncomps dflags && notNull incomps) $ + text "--" <+> text "incompatible with:" + <+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance NamedThing IfaceClassOp where + getName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceClassOp where + occName = getOccName + +instance NamedThing IfaceConDecl where + getName = ifConName + +instance HasOccName IfaceConDecl where + occName = getOccName + +instance NamedThing IfaceDecl where + getName = ifName + +instance HasOccName IfaceDecl where + occName = getOccName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showToIface + +{- +Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The minimal complete definition should only be included if a complete +class definition is shown. Since the minimal complete definition is +anonymous we can't reuse the same mechanism that is used for the +filtering of method signatures. Instead we just check if anything at all is +filtered and hide it in that case. +-} + +data ShowSub + = ShowSub + { ss_how_much :: ShowHowMuch + , ss_forall :: ShowForAllFlag } + +-- See Note [Printing IfaceDecl binders] +-- The alternative pretty printer referred to in the note. +newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) + +data ShowHowMuch + = ShowHeader AltPpr -- ^Header information only, not rhs + | ShowSome [OccName] AltPpr + -- ^ Show only some sub-components. Specifically, + -- + -- [@[]@] Print all sub-components. + -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; + -- elide other sub-components to @...@ + -- May 14: the list is max 1 element long at the moment + | ShowIface + -- ^Everything including GHC-internal information (used in --show-iface) + +{- +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see PprTyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. +-} + +instance Outputable ShowHowMuch where + ppr (ShowHeader _) = text "ShowHeader" + ppr ShowIface = text "ShowIface" + ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs + +showToHeader :: ShowSub +showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing + , ss_forall = ShowForAllWhen } + +showToIface :: ShowSub +showToIface = ShowSub { ss_how_much = ShowIface + , ss_forall = ShowForAllWhen } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = Outputable.empty + +-- show if all sub-components or the complete interface is shown +ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] +ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc +ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowAllSubs _ _ = Outputable.empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True + +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) + where + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, text "..." : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc +pprClassRoles ss clas binders roles = + pprRoles (== Nominal) + (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + binders + roles + +pprClassStandaloneKindSig :: ShowSub -> IfaceTopBndr -> IfaceKind -> SDoc +pprClassStandaloneKindSig ss clas = + pprStandaloneKindSig (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + +constraintIfaceKind :: IfaceKind +constraintIfaceKind = + IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty-printing TyThings] in PprTyThing +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifResKind = kind, + ifRoles = roles, ifCons = condecls, + ifParent = parent, + ifGadtSyntax = gadt, + ifBinders = binders }) + + | gadt = vcat [ pp_roles + , pp_ki_sig + , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , pp_ki_sig + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + -- See Note [Printing foralls in type family instances] in GHC.Iface.Type + pp_data_inst_forall :: SDoc + pp_data_inst_forall = pprUserIfaceForAll forall_bndrs + + forall_bndrs :: [IfaceForAllBndr] + forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] + + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt && not (null cons)) $ text "where" + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + pp_kind = ppUnless (if ki_sig_printable + then isIfaceTauType kind + -- Even in the presence of a standalone kind signature, a non-tau + -- result kind annotation cannot be discarded as it determines the arity. + -- See Note [Arity inference in kcDeclHeader_sig] in TcHsType + else isIfaceLiftedTypeKind kind) + (dcolon <+> ppr kind) + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead suppress_bndr_sig context ss tycon binders + IfDataInstance{} + -> text "instance" <+> pp_data_inst_forall + <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) name_doc binders roles + -- Don't display roles for data family instances (yet) + -- See discussion on #8672. + + ki_sig_printable = + -- If we print a standalone kind signature for a data instance, we leak + -- the internal constructor name: + -- + -- type T15827.R:Dka :: forall k. k -> * + -- data instance forall k (a :: k). D a = MkD (Proxy a) + -- + -- This T15827.R:Dka is a compiler-generated type constructor for the + -- data instance. + not is_data_instance + + pp_ki_sig = ppWhen ki_sig_printable $ + pprStandaloneKindSig name_doc (mkIfaceTyConKind binders kind) + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig ki_sig_printable + + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + + add_bars [] = Outputable.empty + add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc + | otherwise = Nothing + + pp_nd = case condecls of + IfAbstractTyCon{} -> text "data" + IfDataTyCon{} -> text "data" + IfNewTyCon{} -> text "newtype" + + pp_extra = vcat [pprCType ctype] + +pprIfaceDecl ss (IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfAbstractClass }) + = vcat [ pprClassRoles ss clas binders roles + , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) + , text "class" <+> pprIfaceDeclHead suppress_bndr_sig [] ss clas binders <+> pprFundeps fds ] + where + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss (IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs, + ifClassCtxt = context, + ifMinDef = minDef + }}) + = vcat [ pprClassRoles ss clas binders roles + , pprClassStandaloneKindSig ss clas (mkIfaceTyConKind binders constraintIfaceKind) + , text "class" <+> pprIfaceDeclHead suppress_bndr_sig context ss clas binders <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [ vcat asocs, vcat dsigs + , ppShowAllSubs ss (pprMinDef minDef)])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + + pprMinDef :: BooleanFormula IfLclName -> SDoc + pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions + text "{-# MINIMAL" <+> + pprBooleanFormula + (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> + text "#-}" + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss (IfaceSynonym { ifName = tc + , ifBinders = binders + , ifSynRhs = mono_ty + , ifResKind = res_kind}) + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , hang (text "type" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tc binders <+> equals) + 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau + , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) + ] + where + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tc) + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl ss (IfaceFamily { ifName = tycon + , ifFamFlav = rhs, ifBinders = binders + , ifResKind = res_kind + , ifResVar = res_var, ifFamInj = inj }) + | IfaceDataFamilyTyCon <- rhs + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , text "data family" <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders + ] + + | otherwise + = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind) + , hang (text "type family" + <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders + <+> ppShowRhs ss (pp_where rhs)) + 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) + $$ + nest 2 (ppShowRhs ss (pp_branches rhs)) + ] + where + name_doc = pprPrefixIfDeclBndr (ss_how_much ss) (occName tycon) + + pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" + pp_where _ = empty + + pp_inj Nothing _ = empty + pp_inj (Just res) inj + | Injective injectivity <- inj = hsep [ equals, ppr res + , pp_inj_cond res injectivity] + | otherwise = hsep [ equals, ppr res ] + + pp_inj_cond res inj = case filterByList inj binders of + [] -> empty + tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] + + pp_rhs IfaceDataFamilyTyCon + = ppShowIface ss (text "data") + pp_rhs IfaceOpenSynFamilyTyCon + = ppShowIface ss (text "open") + pp_rhs IfaceAbstractClosedSynFamilyTyCon + = ppShowIface ss (text "closed, abstract") + pp_rhs (IfaceClosedSynFamilyTyCon {}) + = empty -- see pp_branches + pp_rhs IfaceBuiltInSynFamTyCon + = ppShowIface ss (text "built-in") + + pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) + = vcat (unzipWith (pprAxBranch + (pprPrefixIfDeclBndr + (ss_how_much ss) + (occName tycon)) + ) $ zip [0..] brs) + $$ ppShowIface ss (text "axiom" <+> ppr ax) + pp_branches _ = Outputable.empty + + -- See Note [Suppressing binder signatures] in GHC.Iface.Type + suppress_bndr_sig = SuppressBndrSig True + +pprIfaceDecl _ (IfacePatSyn { ifName = name, + ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = arg_tys, + ifPatTy = pat_ty} ) + = sdocWithDynFlags mk_msg + where + mk_msg dflags + = hang (text "pattern" <+> pprPrefixOcc name) + 2 (dcolon <+> sep [univ_msg + , pprIfaceContextArr req_ctxt + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , ex_msg + , pprIfaceContextArr prov_ctxt + , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) + where + univ_msg = pprUserIfaceForAll univ_bndrs + ex_msg = pprUserIfaceForAll ex_bndrs + + insert_empty_ctxt = null req_ctxt + && not (null prov_ctxt && isEmpty dflags ex_msg) + +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) + 2 (pprIfaceSigmaType (ss_forall ss) ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (text "axiom" <+> ppr name <+> dcolon) + 2 (vcat $ unzipWith (pprAxBranch (ppr tycon)) $ zip [0..] branches) + +pprCType :: Maybe CType -> SDoc +pprCType Nothing = Outputable.empty +pprCType (Just cType) = text "C type:" <+> ppr cType + +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] + -> [Role] -> SDoc +pprRoles suppress_if tyCon bndrs roles + = sdocWithDynFlags $ \dflags -> + let froles = suppressIfaceInvisibles dflags bndrs roles + in ppUnless (all suppress_if froles || null froles) $ + text "type role" <+> tyCon <+> hsep (map ppr froles) + +pprStandaloneKindSig :: SDoc -> IfaceType -> SDoc +pprStandaloneKindSig tyCon ty = text "type" <+> tyCon <+> text "::" <+> ppr ty + +pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = pprInfixVar (isSymOcc name) (ppr_bndr name) +pprInfixIfDeclBndr _ name + = pprInfixVar (isSymOcc name) (ppr name) + +pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr _ name + = parenSymOcc name (ppr name) + +instance Outputable IfaceClassOp where + ppr = pprIfaceClassOp showToIface + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n ty dm) + = pp_sig n ty $$ generic_dm + where + generic_dm | Just (GenericDM dm_ty) <- dm + = text "default" <+> pp_sig n dm_ty + | otherwise + = empty + pp_sig n ty + = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) + <+> dcolon + <+> pprIfaceSigmaType ShowForAllWhen ty + +instance Outputable IfaceAT where + ppr = pprIfaceAT showToIface + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> Outputable.empty + Just rhs -> nest 2 $ + text "Default:" <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = Outputable.empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = pprIfaceTypeApp topPrec tc tys + +pprIfaceDeclHead :: SuppressBndrSig + -> IfaceContext -> ShowSub -> Name + -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression + -> SDoc +pprIfaceDeclHead suppress_sig context ss tc_occ bndrs + = sdocWithDynFlags $ \ dflags -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) + <+> pprIfaceTyConBinders suppress_sig + (suppressIfaceInvisibles dflags bndrs bndrs) ] + +pprIfaceConDecl :: ShowSub -> Bool + -> IfaceTopBndr + -> [IfaceTyConBinder] + -> IfaceTyConParent + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style tycon tc_binders parent + (IfCon { ifConName = name, ifConInfix = is_infix, + ifConUserTvBinders = user_tvbs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = stricts, ifConFields = fields }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty + | otherwise = ppr_ex_quant pp_h98_con + where + pp_h98_con + | not (null fields) = pp_prefix_con <+> pp_field_args + | is_infix + , [ty1, ty2] <- pp_args + = sep [ ty1 + , pprInfixIfDeclBndr how_much (occName name) + , ty2] + | otherwise = pp_prefix_con <+> sep pp_args + + how_much = ss_how_much ss + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts arg_tys + pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) + + -- If we're pretty-printing a H98-style declaration with existential + -- quantification, then user_tvbs will always consist of the universal + -- tyvar binders followed by the existential tyvar binders. So to recover + -- the visibilities of the existential tyvar binders, we can simply drop + -- the universal tyvar binders from user_tvbs. + ex_tvbs = dropList tc_binders user_tvbs + ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt + pp_gadt_res_ty = mk_user_con_res_ty eq_spec + ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName + pp_tau | null fields + = case pp_args ++ [pp_gadt_res_ty] of + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" + | otherwise + = sep [pp_field_args, arrow <+> pp_gadt_res_ty] + + ppr_bang IfNoBang = whenPprDebug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = text "{-# UNPACK #-}" + ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> + pprParendIfaceCoercion co + + pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc + -- If using record syntax, the only reason one would need to parenthesize + -- a compound field type is if it's preceded by a bang pattern. + pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty + -- If not using record syntax, a compound field type might need to be + -- parenthesized if one of the following holds: + -- + -- 1. We're using Haskell98 syntax. + -- 2. The field type is preceded with a bang pattern. + pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty + + ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc + ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty + + -- If we're displaying the fields GADT-style, e.g., + -- + -- data Foo a where + -- MkFoo :: (Int -> Int) -> Maybe a -> Foo + -- + -- Then we use `funPrec`, since that will ensure `Int -> Int` gets the + -- parentheses that it requires, but simple compound types like `Maybe a` + -- (which don't require parentheses in a function argument position) won't + -- get them, assuming that there are no bang patterns (see bang_prec). + -- + -- If we're displaying the fields Haskell98-style, e.g., + -- + -- data Foo a = MkFoo (Int -> Int) (Maybe a) + -- + -- Then not only must we parenthesize `Int -> Int`, we must also + -- parenthesize compound fields like (Maybe a). Therefore, we pick + -- `appPrec`, which has higher precedence than `funPrec`. + gadt_prec :: PprPrec + gadt_prec + | gadt_style = funPrec + | otherwise = appPrec + + -- The presence of bang patterns or UNPACK annotations requires + -- surrounding the type with parentheses, if needed (#13699) + bang_prec :: IfaceBang -> PprPrec + bang_prec IfNoBang = topPrec + bang_prec IfStrict = appPrec + bang_prec IfUnpack = appPrec + bang_prec IfUnpackCo{} = appPrec + + pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or + -- `!(Maybe a) -> !Int -> ...` + pp_args = map pprArgTy tys_w_strs + + pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or + -- { x :: !(Maybe a), y :: !Int } + pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ + zipWith maybe_show_label fields tys_w_strs + + maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc + maybe_show_label lbl bty + | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ + <+> dcolon <+> pprFieldArgTy bty) + | otherwise = Nothing + where + sel = flSelector lbl + occ = mkVarOccFS (flLabel lbl) + + mk_user_con_res_ty :: IfaceEqSpec -> SDoc + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) + | otherwise + = ppr_tc_app gadt_subst + where + gadt_subst = mkIfaceTySubst eq_spec + + -- When pretty-printing a GADT return type, we: + -- + -- 1. Take the data tycon binders, extract their variable names and + -- visibilities, and construct suitable arguments from them. (This is + -- the role of mk_tc_app_args.) + -- 2. Apply the GADT substitution constructed from the eq_spec. + -- (See Note [Result type of a data family GADT].) + -- 3. Pretty-print the data type constructor applied to its arguments. + -- This process will omit any invisible arguments, such as coercion + -- variables, if necessary. (See Note + -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) + ppr_tc_app gadt_subst = + pprPrefixIfDeclBndr how_much (occName tycon) + <+> pprParendIfaceAppArgs + (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) + + mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs + mk_tc_app_args [] = IA_Nil + mk_tc_app_args (Bndr bndr vis:tc_bndrs) = + IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) + (mk_tc_app_args tc_bndrs) + +instance Outputable IfaceRule where + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleOrph = orph }) + = sep [ hsep [ pprRuleName name + , if isOrphan orph then text "[orphan]" else Outputable.empty + , ppr act + , pp_foralls ] + , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + text "=" <+> ppr rhs]) ] + where + pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot + +instance Outputable IfaceClsInst where + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = hang (text "instance" <+> ppr flag + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr dfun_id) + +instance Outputable IfaceFamInst where + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) + = hang (text "family instance" + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) + 2 (equals <+> ppr tycon_ax) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc + +{- +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. + +----------------------------- Printing IfaceExpr ------------------------------------ +-} + +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +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 + +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 _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) + +pprIfaceExpr add_par i@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +pprIfaceExpr add_par (IfaceECase scrut ty) + = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut + , text "ret_ty" <+> pprParendIfaceType ty + , text "of {}" ]) + +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) + +pprIfaceExpr _ (IfaceCast expr co) + = sep [pprParendIfaceExpr expr, + nest 2 (text "`cast`"), + pprParendIfaceCoercion co] + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [text "let {", + nest 2 (ppr_bind (b, rhs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [text "letrec {", + nest 2 (sep (map ppr_bind pairs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceTick tickish e) + = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) + +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 con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc +ppr_bind (IfLetBndr b ty info ji, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceTickish :: IfaceTickish -> SDoc +pprIfaceTickish (IfaceHpcTick m ix) + = braces (text "tick" <+> ppr m <+> ppr ix) +pprIfaceTickish (IfaceSCC cc tick scope) + = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) +pprIfaceTickish (IfaceSource src _names) + = braces (pprUserRealSpan True src) + +------------------ +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 IfaceConAlt where + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + +------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = Outputable.empty + ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc + <+> if b + then text "<naughty>" + else Outputable.empty + ppr IfDFunId = text "DFunId" + +instance Outputable IfaceIdInfo where + ppr NoInfo = Outputable.empty + ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is + <+> text "-}" + +instance Outputable IfaceInfoItem where + ppr (HsUnfold lb unf) = text "Unfolding" + <> ppWhen lb (text "(loop-breaker)") + <> colon <+> ppr unf + ppr (HsInline prag) = text "Inline:" <+> ppr prag + ppr (HsArity arity) = text "Arity:" <+> int arity + ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str + ppr HsNoCafRefs = text "HasNoCafRefs" + ppr HsLevity = text "Never levity-polymorphic" + +instance Outputable IfaceJoinInfo where + ppr IfaceNotJoinPoint = empty + ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) + +instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = text "<compulsory>" <+> parens (ppr e) + ppr (IfCoreUnfold s e) = (if s + then text "<stable>" + else Outputable.empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) + 2 (sep (map pprParendIfaceExpr es)) + +{- +************************************************************************ +* * + Finding the Names in Iface syntax +* * +************************************************************************ + +This is used for dependency analysis in GHC.Iface.Utils, 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 { ifType = t, ifIdDetails = d, ifIdInfo = i}) + = freeNamesIfType t &&& + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d + +freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k + , ifParent = p, ifCtxt = ctxt, ifCons = cons }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfType res_k &&& + freeNamesIfaceTyConParent p &&& + freeNamesIfContext ctxt &&& + freeNamesIfConDecls cons + +freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k + , ifSynRhs = rhs }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfType rhs + +freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k + , ifFamFlav = flav }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfFamFlav flav + +freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfClassBody cls_body + +freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) + = freeNamesIfTc tc &&& + fnList freeNamesIfAxBranch branches + +freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) + , ifPatBuilder = mb_builder + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = lbls }) + = unitNameSet matcher &&& + maybe emptyNameSet (unitNameSet . fst) mb_builder &&& + freeNamesIfVarBndrs univ_bndrs &&& + freeNamesIfVarBndrs ex_bndrs &&& + freeNamesIfContext prov_ctxt &&& + freeNamesIfContext req_ctxt &&& + fnList freeNamesIfType args &&& + freeNamesIfType pat_ty &&& + mkNameSet (map flSelector lbls) + +freeNamesIfClassBody :: IfaceClassBody -> NameSet +freeNamesIfClassBody IfAbstractClass + = emptyNameSet +freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) + = freeNamesIfContext ctxt &&& + fnList freeNamesIfAT ats &&& + fnList freeNamesIfClsSig sigs + +freeNamesIfAxBranch :: IfaceAxBranch -> NameSet +freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars + , ifaxbCoVars = covars + , ifaxbLHS = lhs + , ifaxbRHS = rhs }) + = fnList freeNamesIfTvBndr tyvars &&& + fnList freeNamesIfIdBndr covars &&& + freeNamesIfAppArgs lhs &&& + freeNamesIfType rhs + +freeNamesIfIdDetails :: IfaceIdDetails -> NameSet +freeNamesIfIdDetails (IfRecSelId tc _) = + either freeNamesIfTc freeNamesIfDecl tc +freeNamesIfIdDetails _ = emptyNameSet + +-- All other changes are handled via the version info on the tycon +freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet +freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet +freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet + +freeNamesIfContext :: IfaceContext -> NameSet +freeNamesIfContext = fnList freeNamesIfType + +freeNamesIfAT :: IfaceAT -> NameSet +freeNamesIfAT (IfaceAT decl mb_def) + = freeNamesIfDecl decl &&& + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs + +freeNamesIfClsSig :: IfaceClassOp -> NameSet +freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm + +freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet +freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty +freeNamesDM _ = emptyNameSet + +freeNamesIfConDecls :: IfaceConDecls -> NameSet +freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet + +freeNamesIfConDecl :: IfaceConDecl -> NameSet +freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt + , ifConArgTys = arg_tys + , ifConFields = flds + , ifConEqSpec = eq_spec + , ifConStricts = bangs }) + = fnList freeNamesIfBndr ex_tvs &&& + freeNamesIfContext ctxt &&& + fnList freeNamesIfType arg_tys &&& + mkNameSet (map flSelector flds) &&& + fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints + fnList freeNamesIfBang bangs + +freeNamesIfBang :: IfaceBang -> NameSet +freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co +freeNamesIfBang _ = emptyNameSet + +freeNamesIfKind :: IfaceType -> NameSet +freeNamesIfKind = freeNamesIfType + +freeNamesIfAppArgs :: IfaceAppArgs -> NameSet +freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts +freeNamesIfAppArgs IA_Nil = emptyNameSet + +freeNamesIfType :: IfaceType -> NameSet +freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet +freeNamesIfType (IfaceTyVar _) = emptyNameSet +freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts +freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c +freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c + +freeNamesIfMCoercion :: IfaceMCoercion -> NameSet +freeNamesIfMCoercion IfaceMRefl = emptyNameSet +freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co + +freeNamesIfCoercion :: IfaceCoercion -> NameSet +freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t +freeNamesIfCoercion (IfaceGReflCo _ t mco) + = freeNamesIfType t &&& freeNamesIfMCoercion mco +freeNamesIfCoercion (IfaceFunCo _ c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) + = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAppCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceForAllCo _ kind_co co) + = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet +freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet +freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) + = unitNameSet ax &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) + = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceSymCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceTransCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceNthCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceLRCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceInstCo co co2) + = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 +freeNamesIfCoercion (IfaceKindCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceSubCo co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) + -- the axiom is just a string, so we don't count it as a name. + = fnList freeNamesIfCoercion cos + +freeNamesIfProv :: IfaceUnivCoProv -> NameSet +freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet +freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfacePluginProv _) = emptyNameSet + +freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet +freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr + +freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet +freeNamesIfVarBndrs = fnList freeNamesIfVarBndr + +freeNamesIfBndr :: IfaceBndr -> NameSet +freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b +freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b + +freeNamesIfBndrs :: [IfaceBndr] -> NameSet +freeNamesIfBndrs = fnList freeNamesIfBndr + +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 _ji) = freeNamesIfType ty + &&& freeNamesIfIdInfo info + +freeNamesIfTvBndr :: IfaceTvBndr -> NameSet +freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k + -- kinds can have Names inside, because of promotion + +freeNamesIfIdBndr :: IfaceIdBndr -> NameSet +freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k + +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 (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es + +freeNamesIfExpr :: IfaceExpr -> NameSet +freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion 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 &&& freeNamesIfCoercion co +freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e +freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts + where + 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 + +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body + +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs + +freeNamesIfExpr _ = emptyNameSet + +freeNamesIfTc :: IfaceTyCon -> NameSet +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) +-- ToDo: shouldn't we include IfaceIntTc & co.? + +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName + +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys + +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSet + +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f + +{- +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. + + +************************************************************************ +* * + Binary instances +* * +************************************************************************ + +Note that there is a bit of subtlety here when we encode names. While +IfaceTopBndrs is really just a synonym for Name, we need to take care to +encode them with {get,put}IfaceTopBndr. The difference becomes important when +we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for +details. + +-} + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + putIfaceTopBndr bh name + lazyPut bh (ty, details, idinfo) + -- See Note [Lazy deserialization of IfaceId] + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 2 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do + putByte bh 3 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do + putByte bh 4 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + + -- NB: Written in a funny way to avoid an interface change + put_ bh (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8 + }}) = do + putByte bh 5 + put_ bh a1 + putIfaceTopBndr bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 6 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putByte bh 7 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + put_ bh a11 + + put_ bh (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) = do + putByte bh 8 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ~(ty, details, idinfo) <- lazyGet bh + -- See Note [Lazy deserialization of IfaceId] + return (IfaceId name ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) + 3 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceSynonym a1 a2 a3 a4 a5) + 4 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfaceFamily a1 a2 a3 a4 a5 a6) + 5 -> do a1 <- get bh + a2 <- getIfaceTopBndr bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8 + }}) + 6 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceAxiom a1 a2 a3 a4) + 7 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + a11 <- get bh + return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + 8 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +{- Note [Lazy deserialization of IfaceId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The use of lazyPut and lazyGet in the IfaceId Binary instance is +purely for performance reasons, to avoid deserializing details about +identifiers that will never be used. It's not involved in tying the +knot in the type checker. It saved ~1% of the total build time of GHC. + +When we read an interface file, we extend the PTE, a mapping of Names +to TyThings, with the declarations we have read. The extension of the +PTE is strict in the Names, but not in the TyThings themselves. +GHC.Iface.Load.loadDecl calculates the list of (Name, TyThing) bindings to +add to the PTE. For an IfaceId, there's just one binding to add; and +the ty, details, and idinfo fields of an IfaceId are used only in the +TyThing. So by reading those fields lazily we may be able to save the +work of ever having to deserialize them (into IfaceType, etc.). + +For IfaceData and IfaceClass, loadDecl creates extra implicit bindings +(the constructors and field selectors of the data declaration, or the +methods of the class), whose Names depend on more than just the Name +of the type constructor or class itself. So deserializing them lazily +would be more involved. Similar comments apply to the other +constructors of IfaceDecl with the additional point that they probably +represent a small proportion of all declarations. +-} + +instance Binary IfaceFamTyConFlav where + put_ bh IfaceDataFamilyTyCon = putByte bh 0 + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 + put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceDataFamilyTyCon + 1 -> return IfaceOpenSynFamilyTyCon + 2 -> do { mb <- get bh + ; return (IfaceClosedSynFamilyTyCon mb) } + 3 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" + (ppr (fromIntegral h :: Int)) } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n ty def) = do + putIfaceTopBndr bh n + put_ bh ty + put_ bh def + get bh = do + n <- getIfaceTopBndr bh + ty <- get bh + def <- get bh + return (IfaceClassOp n ty def) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) + +instance Binary IfaceConDecls where + put_ bh IfAbstractTyCon = putByte bh 0 + put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfAbstractTyCon + 1 -> liftM IfDataTyCon (get bh) + 2 -> liftM IfNewTyCon (get bh) + _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh (length a9) + mapM_ (put_ bh) a9 + put_ bh a10 + put_ bh a11 + get bh = do + a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + n_fields <- get bh + a9 <- replicateM n_fields (get bh) + a10 <- get bh + a11 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + +instance Binary IfaceSrcBang where + put_ bh (IfSrcBang a1 a2) = + do put_ bh a1 + put_ bh a2 + + get bh = + do a1 <- get bh + a2 <- get bh + return (IfSrcBang a1 a2) + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh IfDFunId = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> return IfDFunId + +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + put_ bh HsLevity = putByte bh 5 + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + 4 -> return HsNoCafRefs + _ -> return HsLevity + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfDFunUnfold as bs) = do + putByte bh 2 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 3 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam (ae, os) af) = do + putByte bh 4 + put_ bh ae + put_ bh os + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + os <- get bh + af <- get bh + return (IfaceLam (ae, os) af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + put_ bh (IfaceSource src name) = do + putByte bh 2 + put_ bh (srcSpanFile src) + put_ bh (srcSpanStartLine src) + put_ bh (srcSpanStartCol src) + put_ bh (srcSpanEndLine src) + put_ bh (srcSpanEndCol src) + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + 2 -> do file <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + let start = mkRealSrcLoc file sl sc + end = mkRealSrcLoc file el ec + name <- get bh + return (IfaceSource (mkRealSrcSpan start end) name) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfLetBndr a b c d) + +instance Binary IfaceJoinInfo where + put_ bh IfaceNotJoinPoint = putByte bh 0 + put_ bh (IfaceJoinPoint ar) = do + putByte bh 1 + put_ bh ar + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceNotJoinPoint + _ -> liftM IfaceJoinPoint $ get bh + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty + +instance Binary IfaceCompleteMatch where + put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts + get bh = IfaceCompleteMatch <$> get bh <*> get bh + + +{- +************************************************************************ +* * + NFData instances + See Note [Avoiding space leaks in toIface*] in GHC.CoreToIface +* * +************************************************************************ +-} + +instance NFData IfaceDecl where + rnf = \case + IfaceId f1 f2 f3 f4 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 + + IfaceData f1 f2 f3 f4 f5 f6 f7 f8 f9 -> + f1 `seq` seqList f2 `seq` f3 `seq` f4 `seq` f5 `seq` + rnf f6 `seq` rnf f7 `seq` rnf f8 `seq` rnf f9 + + IfaceSynonym f1 f2 f3 f4 f5 -> + rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + + IfaceFamily f1 f2 f3 f4 f5 f6 -> + rnf f1 `seq` rnf f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 `seq` f6 `seq` () + + IfaceClass f1 f2 f3 f4 f5 -> + rnf f1 `seq` f2 `seq` seqList f3 `seq` rnf f4 `seq` rnf f5 + + IfaceAxiom nm tycon role ax -> + rnf nm `seq` + rnf tycon `seq` + role `seq` + rnf ax + + IfacePatSyn f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 -> + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` f6 `seq` + rnf f7 `seq` rnf f8 `seq` rnf f9 `seq` rnf f10 `seq` f11 `seq` () + +instance NFData IfaceAxBranch where + rnf (IfaceAxBranch f1 f2 f3 f4 f5 f6 f7) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` rnf f7 + +instance NFData IfaceClassBody where + rnf = \case + IfAbstractClass -> () + IfConcreteClass f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + +instance NFData IfaceAT where + rnf (IfaceAT f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceClassOp where + rnf (IfaceClassOp f1 f2 f3) = rnf f1 `seq` rnf f2 `seq` f3 `seq` () + +instance NFData IfaceTyConParent where + rnf = \case + IfNoParent -> () + IfDataInstance f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + +instance NFData IfaceConDecls where + rnf = \case + IfAbstractTyCon -> () + IfDataTyCon f1 -> rnf f1 + IfNewTyCon f1 -> rnf f1 + +instance NFData IfaceConDecl where + rnf (IfCon f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` f5 `seq` rnf f6 `seq` + rnf f7 `seq` rnf f8 `seq` f9 `seq` rnf f10 `seq` rnf f11 + +instance NFData IfaceSrcBang where + rnf (IfSrcBang f1 f2) = f1 `seq` f2 `seq` () + +instance NFData IfaceBang where + rnf x = x `seq` () + +instance NFData IfaceIdDetails where + rnf = \case + IfVanillaId -> () + IfRecSelId (Left tycon) b -> rnf tycon `seq` rnf b + IfRecSelId (Right decl) b -> rnf decl `seq` rnf b + IfDFunId -> () + +instance NFData IfaceIdInfo where + rnf = \case + NoInfo -> () + HasInfo f1 -> rnf f1 + +instance NFData IfaceInfoItem where + rnf = \case + HsArity a -> rnf a + HsStrictness str -> seqStrictSig str + HsInline p -> p `seq` () -- TODO: seq further? + HsUnfold b unf -> rnf b `seq` rnf unf + HsNoCafRefs -> () + HsLevity -> () + +instance NFData IfaceUnfolding where + rnf = \case + IfCoreUnfold inlinable expr -> + rnf inlinable `seq` rnf expr + IfCompulsory expr -> + rnf expr + IfInlineRule arity b1 b2 e -> + rnf arity `seq` rnf b1 `seq` rnf b2 `seq` rnf e + IfDFunUnfold bndrs exprs -> + rnf bndrs `seq` rnf exprs + +instance NFData IfaceExpr where + rnf = \case + IfaceLcl nm -> rnf nm + IfaceExt nm -> rnf nm + IfaceType ty -> rnf ty + IfaceCo co -> rnf co + IfaceTuple sort exprs -> sort `seq` rnf exprs + IfaceLam bndr expr -> rnf bndr `seq` rnf expr + IfaceApp e1 e2 -> rnf e1 `seq` rnf e2 + IfaceCase e nm alts -> rnf e `seq` nm `seq` rnf alts + IfaceECase e ty -> rnf e `seq` rnf ty + IfaceLet bind e -> rnf bind `seq` rnf e + IfaceCast e co -> rnf e `seq` rnf co + IfaceLit l -> l `seq` () -- FIXME + IfaceFCall fc ty -> fc `seq` rnf ty + IfaceTick tick e -> rnf tick `seq` rnf e + +instance NFData IfaceBinding where + rnf = \case + IfaceNonRec bndr e -> rnf bndr `seq` rnf e + IfaceRec binds -> rnf binds + +instance NFData IfaceLetBndr where + rnf (IfLetBndr nm ty id_info join_info) = + rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info + +instance NFData IfaceFamTyConFlav where + rnf = \case + IfaceDataFamilyTyCon -> () + IfaceOpenSynFamilyTyCon -> () + IfaceClosedSynFamilyTyCon f1 -> rnf f1 + IfaceAbstractClosedSynFamilyTyCon -> () + IfaceBuiltInSynFamTyCon -> () + +instance NFData IfaceJoinInfo where + rnf x = x `seq` () + +instance NFData IfaceTickish where + rnf = \case + IfaceHpcTick m i -> rnf m `seq` rnf i + IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2 + IfaceSource src str -> src `seq` rnf str + +instance NFData IfaceConAlt where + rnf = \case + IfaceDefault -> () + IfaceDataAlt nm -> rnf nm + IfaceLitAlt lit -> lit `seq` () + +instance NFData IfaceCompleteMatch where + rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2 + +instance NFData IfaceRule where + rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) = + rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` f8 `seq` () + +instance NFData IfaceFamInst where + rnf (IfaceFamInst f1 f2 f3 f4) = + rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` () + +instance NFData IfaceClsInst where + rnf (IfaceClsInst f1 f2 f3 f4 f5) = + f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` () + +instance NFData IfaceAnnotation where + rnf (IfaceAnnotation f1 f2) = f1 `seq` f2 `seq` () diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs new file mode 100644 index 0000000000..1a7f9f0026 --- /dev/null +++ b/compiler/GHC/Iface/Tidy.hs @@ -0,0 +1,1487 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Tidying up Core} +-} + +{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-} + +module GHC.Iface.Tidy ( + mkBootModDetailsTc, tidyProgram + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcRnTypes +import DynFlags +import CoreSyn +import CoreUnfold +import CoreFVs +import CoreTidy +import CoreMonad +import GHC.CoreToStg.Prep +import CoreUtils (rhsIsStatic) +import CoreStats (coreBindsStats, CoreStats(..)) +import CoreSeq (seqBinds) +import CoreLint +import Literal +import Rules +import PatSyn +import ConLike +import CoreArity ( exprArity, exprBotStrictness_maybe ) +import StaticPtrTable +import VarEnv +import VarSet +import Var +import Id +import MkId ( mkDictSelRhs ) +import IdInfo +import InstEnv +import Type ( tidyTopType ) +import Demand ( appIsBottom, isTopSig, isBottomingSig ) +import BasicTypes +import Name hiding (varName) +import NameSet +import NameCache +import Avail +import GHC.Iface.Env +import TcEnv +import TcRnMonad +import DataCon +import TyCon +import Class +import Module +import Packages( isDllName ) +import HscTypes +import Maybes +import UniqSupply +import Outputable +import Util( filterOut ) +import qualified ErrUtils as Err + +import Control.Monad +import Data.Function +import Data.List ( sortBy, mapAccumL ) +import Data.IORef ( atomicModifyIORef' ) + +{- +Constructing the TypeEnv, Instances, Rules from which the +ModIface is constructed, and which goes on to subsequent modules in +--make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +************************************************************************ +* * + Plan A: simpleTidyPgm +* * +************************************************************************ + + +Plan A: mkBootModDetails: omit pragmas, make interfaces small +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Tidy the bindings, to ensure that the Caf and Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting + +* If this an hsig file, drop the instances altogether too (they'll + get pulled in by the implicit module import. +-} + +-- This is Plan A: make a small type env when typechecking only, +-- or when compiling a hs-boot file, or simply when not using -O +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files + +mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc hsc_env + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, -- just for the Ids + tcg_tcs = tcs, + tcg_patsyns = pat_syns, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_complete_matches = complete_sigs, + tcg_mod = this_mod + } + = -- This timing isn't terribly useful since the result isn't forced, but + -- the message is useful to locating oneself in the compilation process. + Err.withTiming dflags + (text "CoreTidy"<+>brackets (ppr this_mod)) + (const ()) $ + return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_complete_sigs = complete_sigs + }) + where + dflags = hsc_dflags hsc_env + + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + -- + -- Do make sure that we keep Ids that are already Global. + -- When typechecking an .hs-boot file, the Ids come through as + -- GlobalIds. + final_ids = [ globaliseAndTidyBootId id + | id <- typeEnvIds type_env + , keep_it id ] + + final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts + insts' = mkFinalClsInsts type_env1 insts + pat_syns' = mkFinalPatSyns type_env1 pat_syns + type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 + + -- Default methods have their export flag set (isExportedId), + -- but everything else doesn't (yet), because this is + -- pre-desugaring, so we must test against the exports too. + keep_it id | isWiredInName id_name = False + -- See Note [Drop wired-in things] + | isExportedId id = True + | id_name `elemNameSet` exp_names = True + | otherwise = False + where + id_name = idName id + + exp_names = availsToNameSet exports + +lookupFinalId :: TypeEnv -> Id -> Id +lookupFinalId type_env id + = case lookupTypeEnv type_env (idName id) of + Just (AnId id') -> id' + _ -> pprPanic "lookup_final_id" (ppr id) + +mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] +mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) + +mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn] +mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env)) + +extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv +extendTypeEnvWithPatSyns tidy_patsyns type_env + = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ] + +globaliseAndTidyBootId :: Id -> Id +-- For a LocalId with an External Name, +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity) +-- * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface) +globaliseAndTidyBootId id + = globaliseId id `setIdType` tidyTopType (idType id) + `setIdUnfolding` BootUnfolding + +{- +************************************************************************ +* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +* * +************************************************************************ + +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Step 1: Figure out which Ids are externally visible + See Note [Choosing external Ids] + +* Step 2: Gather the externally visible rules, separately from + the top-level bindings. + See Note [Finding external rules] + +* Step 3: Tidy the bindings, externalising appropriate Ids + See Note [Tidy the top-level bindings] + +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) + +Note [Choosing external Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also the section "Interface stability" in the +recompilation-avoidance commentary: + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +First we figure out which Ids are "external" Ids. An +"external" Id is one that is visible from outside the compilation +unit. These are + a) the user exported ones + b) the ones bound to static forms + c) ones mentioned in the unfoldings, workers, or + rules of externally-visible ones + +While figuring out which Ids are external, we pick a "tidy" OccName +for each one. That is, we make its OccName distinct from the other +external OccNames in this module, so that in interface files and +object code we can refer to it unambiguously by its OccName. The +OccName for each binder is prefixed by the name of the exported Id +that references it; e.g. if "f" references "x" in its unfolding, then +"x" is renamed to "f_x". This helps distinguish the different "x"s +from each other, and means that if "f" is later removed, things that +depend on the other "x"s will not need to be recompiled. Of course, +if there are multiple "f_x"s, then we have to disambiguate somehow; we +use "f_x0", "f_x1" etc. + +As far as possible we should assign names in a deterministic fashion. +Each time this module is compiled with the same options, we should end +up with the same set of external names with the same types. That is, +the ABI hash in the interface should not change. This turns out to be +quite tricky, since the order of the bindings going into the tidy +phase is already non-deterministic, as it is based on the ordering of +Uniques, which are assigned unpredictably. + +To name things in a stable way, we do a depth-first-search of the +bindings, starting from the exports sorted by name. This way, as long +as the bindings themselves are deterministic (they sometimes aren't!), +the order in which they are presented to the tidying phase does not +affect the names we assign. + +Note [Tidy the top-level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Next we traverse the bindings top to bottom. For each *top-level* +binder + + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id + + 2. Give it a system-wide Unique. + [Even non-exported things need system-wide Uniques because the + byte-code generator builds a single Name->BCO symbol table.] + + We use the NameCache kept in the HscEnv as the + source of such system-wide uniques. + + For external Ids, use the original-name cache in the NameCache + to ensure that the unique assigned is the same as the Id had + in any previous compilation run. + + 3. Rename top-level Ids according to the names we chose in step 1. + If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. This is used by the code generator + to decide whether to make the label externally visible + + 4. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS + + +Finally, substitute these new top-level binders consistently +throughout, including in unfoldings. We also tidy binders in +RHSs, so that they print nicely in interfaces. +-} + +tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram hsc_env (ModGuts { mg_module = mod + , mg_exports = exports + , mg_rdr_env = rdr_env + , mg_tcs = tcs + , mg_insts = cls_insts + , mg_fam_insts = fam_insts + , mg_binds = binds + , mg_patsyns = patsyns + , mg_rules = imp_rules + , mg_anns = anns + , mg_complete_sigs = complete_sigs + , mg_deps = deps + , mg_foreign = foreign_stubs + , mg_foreign_files = foreign_files + , mg_hpc_info = hpc_info + , mg_modBreaks = modBreaks + }) + + = Err.withTiming dflags + (text "CoreTidy"<+>brackets (ppr mod)) + (const ()) $ + do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags + ; expose_all = gopt Opt_ExposeAllUnfoldings dflags + ; print_unqual = mkPrintUnqualified dflags rdr_env + ; implicit_binds = concatMap getImplicitBinds tcs + } + + ; (unfold_env, tidy_occ_env) + <- chooseExternalIds hsc_env mod omit_prags expose_all + binds implicit_binds imp_rules + ; let { (trimmed_binds, trimmed_rules) + = findExternalRules omit_prags binds imp_rules unfold_env } + + ; (tidy_env, tidy_binds) + <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds + + -- See Note [Grand plan for static forms] in StaticPtrTable. + ; (spt_entries, tidy_binds') <- + sptCreateStaticBinds hsc_env mod tidy_binds + ; let { spt_init_code = sptModuleInitCode mod spt_entries + ; add_spt_init_code = + case hscTarget dflags of + -- If we are compiling for the interpreter we will insert + -- any necessary SPT entries dynamically + HscInterpreted -> id + -- otherwise add a C stub to do so + _ -> (`appendStubC` spt_init_code) + + -- The completed type environment is gotten from + -- a) the types and classes defined here (plus implicit things) + -- b) adding Ids with correct IdInfo, including unfoldings, + -- gotten from the bindings + -- From (b) we keep only those Ids with External names; + -- the CoreTidy pass makes sure these are all and only + -- the externally-accessible ones + -- This truncates the type environment to include only the + -- exported Ids and things needed from them, which saves space + -- + -- See Note [Don't attempt to trim data types] + ; final_ids = [ if omit_prags then trimId id else id + | id <- bindersOfBinds tidy_binds + , isExternalName (idName id) + , not (isWiredIn id) + ] -- See Note [Drop wired-in things] + + ; final_tcs = filterOut isWiredIn tcs + -- See Note [Drop wired-in things] + ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts + ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts + ; tidy_patsyns = mkFinalPatSyns type_env patsyns + ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + ; tidy_rules = tidyRules tidy_env trimmed_rules + + ; -- See Note [Injecting implicit bindings] + all_tidy_binds = implicit_binds ++ tidy_binds' + + -- Get the TyCons to generate code for. Careful! We must use + -- the untidied TyCons here, because we need + -- (a) implicit TyCons arising from types and classes defined + -- in this module + -- (b) wired-in TyCons, which are normally removed from the + -- TypeEnv we put in the ModDetails + -- (c) Constructors even if they are not exported (the + -- tidied TypeEnv has trimmed these away) + ; alg_tycons = filter isAlgTyCon tcs + } + + ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + + -- If the endPass didn't print the rules, but ddump-rules is + -- on, print now + ; unless (dopt Opt_D_dump_simpl dflags) $ + Err.dumpIfSet_dyn dflags Opt_D_dump_rules + (showSDoc dflags (ppr CoreTidy <+> text "rules")) + Err.FormatText + (pprRulesForUser dflags tidy_rules) + + -- Print one-line size info + ; let cs = coreBindsStats tidy_binds + ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" + Err.FormatText + (text "Tidy size (terms,types,coercions)" + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs) ) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = all_tidy_binds, + cg_foreign = add_spt_init_code foreign_stubs, + cg_foreign_files = foreign_files, + cg_dep_pkgs = map fst $ dep_pkgs deps, + cg_hpc_info = hpc_info, + cg_modBreaks = modBreaks, + cg_spt_entries = spt_entries }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_cls_insts, + md_fam_insts = fam_insts, + md_exports = exports, + md_anns = anns, -- are already tidy + md_complete_sigs = complete_sigs + }) + } + where + dflags = hsc_dflags hsc_env + +-------------------------- +trimId :: Id -> Id +trimId id + | not (isImplicitId id) + = id `setIdInfo` vanillaIdInfo + | otherwise + = id + +{- Note [Drop wired-in things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We never put wired-in TyCons or Ids in an interface file. +They are wired-in, so the compiler knows about them already. + +Note [Don't attempt to trim data types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some time GHC tried to avoid exporting the data constructors +of a data type if it wasn't strictly necessary to do so; see #835. +But "strictly necessary" accumulated a longer and longer list +of exceptions, and finally I gave up the battle: + + commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11 + Author: Simon Peyton Jones <simonpj@microsoft.com> + Date: Thu Dec 6 16:03:16 2012 +0000 + + Stop attempting to "trim" data types in interface files + + Without -O, we previously tried to make interface files smaller + by not including the data constructors of data types. But + there are a lot of exceptions, notably when Template Haskell is + involved or, more recently, DataKinds. + + However #7445 shows that even without TemplateHaskell, using + the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ + is enough to require us to expose the data constructors. + + So I've given up on this "optimisation" -- it's probably not + important anyway. Now I'm simply not attempting to trim off + the data constructors. The gain in simplicity is worth the + modest cost in interface file growth, which is limited to the + bits reqd to describe those data constructors. + +************************************************************************ +* * + Implicit bindings +* * +************************************************************************ + +Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inject the implicit bindings right at the end, in CoreTidy. +Some of these bindings, notably record selectors, are not +constructed in an optimised form. E.g. record selector for + data T = MkT { x :: {-# UNPACK #-} !Int } +Then the unfolding looks like + x = \t. case t of MkT x1 -> let x = I# x1 in x +This generates bad code unless it's first simplified a bit. That is +why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of +optimisation first. (Only matters when the selector is used curried; +eg map x ys.) See #2070. + +[Oct 09: in fact, record selectors are no longer implicit Ids at all, +because we really do want to optimise them properly. They are treated +much like any other Id. But doing "light" optimisation on an implicit +Id still makes sense.] + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +because GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (#2844). +It's much safer just to inject them right at the end, after tidying. + +Oh: two other reasons for injecting them late: + + - If implicit Ids are already in the bindings when we start tidying, + we'd have to be careful not to treat them as external Ids (in + the sense of chooseExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = <blah> + but nothing referring to a18 (because the implicit Id is the + one that does, and implicit Ids don't appear in interface files). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + +There is one sort of implicit binding that is injected still later, +namely those for data constructor workers. Reason (I think): it's +really just a code generation trick.... binding itself makes no sense. +See Note [Data constructor workers] in CorePrep. +-} + +getImplicitBinds :: TyCon -> [CoreBind] +getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc + where + cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc) + +getTyConImplicitBinds :: TyCon -> [CoreBind] +getTyConImplicitBinds tc + | isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId + | otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) + +getClassImplicitBinds :: Class -> [CoreBind] +getClassImplicitBinds cls + = [ NonRec op (mkDictSelRhs cls val_index) + | (op, val_index) <- classAllSelIds cls `zip` [0..] ] + +get_defn :: Id -> CoreBind +get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id)) + +{- +************************************************************************ +* * +\subsection{Step 1: finding externals} +* * +************************************************************************ + +See Note [Choosing external Ids]. +-} + +type UnfoldEnv = IdEnv (Name{-new name-}, Bool {-show unfolding-}) + -- Maps each top-level Id to its new Name (the Id is tidied in step 2) + -- The Unique is unchanged. If the new Name is external, it will be + -- visible in the interface file. + -- + -- Bool => expose unfolding or not. + +chooseExternalIds :: HscEnv + -> Module + -> Bool -> Bool + -> [CoreBind] + -> [CoreBind] + -> [CoreRule] + -> IO (UnfoldEnv, TidyOccEnv) + -- Step 1 from the notes above + +chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules + = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env + ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders + ; tidy_internal internal_ids unfold_env1 occ_env1 } + where + nc_var = hsc_NC hsc_env + + -- init_ext_ids is the initial list of Ids that should be + -- externalised. It serves as the starting point for finding a + -- deterministic, tidy, renaming for all external Ids in this + -- module. + -- + -- It is sorted, so that it has a deterministic order (i.e. it's the + -- same list every time this module is compiled), in contrast to the + -- bindings, which are ordered non-deterministically. + init_work_list = zip init_ext_ids init_ext_ids + init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders + + -- An Id should be external if either (a) it is exported, + -- (b) it appears in the RHS of a local rule for an imported Id, or + -- See Note [Which rules to expose] + is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars + + rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules + + binders = map fst $ flattenBinds binds + implicit_binders = bindersOfBinds implicit_binds + binder_set = mkVarSet binders + + avoids = [getOccName name | bndr <- binders ++ implicit_binders, + let name = idName bndr, + isExternalName name ] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. + -- In particular, the set of binders doesn't include + -- implicit Ids at this stage. + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_occ_env = initTidyOccEnv avoids + + + search :: [(Id,Id)] -- The work-list: (external id, referring id) + -- Make a tidy, external Name for the external id, + -- add it to the UnfoldEnv, and do the same for the + -- transitive closure of Ids it refers to + -- The referring id is used to generate a tidy + --- name for the external id + -> UnfoldEnv -- id -> (new Name, show_unfold) + -> TidyOccEnv -- occ env for choosing new Names + -> IO (UnfoldEnv, TidyOccEnv) + + search [] unfold_env occ_env = return (unfold_env, occ_env) + + search ((idocc,referrer) : rest) unfold_env occ_env + | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env + | otherwise = do + (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc + let + (new_ids, show_unfold) + | omit_prags = ([], False) + | otherwise = addExternal expose_all refined_id + + -- 'idocc' is an *occurrence*, but we need to see the + -- unfolding in the *definition*; so look up in binder_set + refined_id = case lookupVarSet binder_set idocc of + Just id -> id + Nothing -> WARN( True, ppr idocc ) idocc + + unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + referrer' | isExportedId refined_id = refined_id + | otherwise = referrer + -- + search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env' + + tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv + -> IO (UnfoldEnv, TidyOccEnv) + tidy_internal [] unfold_env occ_env = return (unfold_env,occ_env) + tidy_internal (id:ids) unfold_env occ_env = do + (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id + let unfold_env' = extendVarEnv unfold_env id (name',False) + tidy_internal ids unfold_env' occ_env' + +addExternal :: Bool -> Id -> ([Id], Bool) +addExternal expose_all id = (new_needed_ids, show_unfold) + where + new_needed_ids = bndrFvsInOrder show_unfold id + idinfo = idInfo id + show_unfold = show_unfolding (unfoldingInfo idinfo) + never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + loop_breaker = isStrongLoopBreaker (occInfo idinfo) + bottoming_fn = isBottomingSig (strictnessInfo idinfo) + + -- Stuff to do with the Id's unfolding + -- We leave the unfolding there even if there is a worker + -- In GHCi the unfolding is used by importers + + show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) + = expose_all -- 'expose_all' says to expose all + -- unfoldings willy-nilly + + || isStableSource src -- Always expose things whose + -- source is an inline rule + + || not (bottoming_fn -- No need to inline bottom functions + || never_active -- Or ones that say not to + || loop_breaker -- Or that are loop breakers + || neverUnfoldGuidance guidance) + show_unfolding (DFunUnfolding {}) = True + show_unfolding _ = False + +{- +************************************************************************ +* * + Deterministic free variables +* * +************************************************************************ + +We want a deterministic free-variable list. exprFreeVars gives us +a VarSet, which is in a non-deterministic order when converted to a +list. Hence, here we define a free-variable finder that returns +the free variables in the order that they are encountered. + +See Note [Choosing external Ids] +-} + +bndrFvsInOrder :: Bool -> Id -> [Id] +bndrFvsInOrder show_unfold id + = run (dffvLetBndr show_unfold id) + +run :: DFFV () -> [Id] +run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of + ((_,ids),_) -> ids + +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope + -- we don't want to record these as free vars + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> ((VarSet,[Var]),a)) -- Output state + deriving (Functor) + +instance Applicative DFFV where + pure a = DFFV $ \_ st -> (st, a) + (<*>) = ap + +instance Monad DFFV where + (DFFV m) >>= k = DFFV $ \env st -> + case m env st of + (st',a) -> case k a of + DFFV f -> f env st' + +extendScope :: Var -> DFFV a -> DFFV a +extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) + +extendScopeList :: [Var] -> DFFV a -> DFFV a +extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) + +insert :: Var -> DFFV () +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && + not (v `elemVarSet` env) && + not (v `elemVarSet` set) + in if keep_me + then ((extendVarSet set v, v:ids), ()) + else ((set, ids), ()) + + +dffvExpr :: CoreExpr -> DFFV () +dffvExpr (Var v) = insert v +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e +dffvExpr (Tick _other e) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ + (mapM_ dffvBind prs >> dffvExpr e) +dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) +dffvExpr _other = return () + +dffvAlt :: (t, [Var], CoreExpr) -> DFFV () +dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) + +dffvBind :: (Id, CoreExpr) -> DFFV () +dffvBind(x,r) + | not (isId x) = dffvExpr r + | otherwise = dffvLetBndr False x >> dffvExpr r + -- Pass False because we are doing the RHS right here + -- If you say True you'll get *exponential* behaviour! + +dffvLetBndr :: Bool -> Id -> DFFV () +-- Gather the free vars of the RULES and unfolding of a binder +-- We always get the free vars of a *stable* unfolding, but +-- for a *vanilla* one (InlineRhs), the flag controls what happens: +-- True <=> get fvs of even a *vanilla* unfolding +-- False <=> ignore an InlineRhs +-- For nested bindings (call from dffvBind) we always say "False" because +-- we are taking the fvs of the RHS anyway +-- For top-level bindings (call from addExternal, via bndrFvsInOrder) +-- we say "True" if we are exposing that unfolding +dffvLetBndr vanilla_unfold id + = do { go_unf (unfoldingInfo idinfo) + ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } + where + idinfo = idInfo id + + go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + = case src of + InlineRhs | vanilla_unfold -> dffvExpr rhs + | otherwise -> return () + _ -> dffvExpr rhs + + go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = extendScopeList bndrs $ mapM_ dffvExpr args + go_unf _ = return () + + go_rule (BuiltinRule {}) = return () + go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) + = extendScopeList bndrs (dffvExpr rhs) + +{- +************************************************************************ +* * + findExternalRules +* * +************************************************************************ + +Note [Finding external rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The complete rules are gotten by combining + a) local rules for imported Ids + b) rules embedded in the top-level Ids + +There are two complications: + * Note [Which rules to expose] + * Note [Trimming auto-rules] + +Note [Which rules to expose] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function 'expose_rule' filters out rules that mention, on the LHS, +Ids that aren't externally visible; these rules can't fire in a client +module. + +The externally-visible binders are computed (by chooseExternalIds) +assuming that all orphan rules are externalised (see init_ext_ids in +function 'search'). So in fact it's a bit conservative and we may +export more than we need. (It's a sort of mutual recursion.) + +Note [Trimming auto-rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Second, with auto-specialisation we may specialise local or imported +dfuns or INLINE functions, and then later inline them. That may leave +behind something like + RULE "foo" forall d. f @ Int d = f_spec +where f is either local or imported, and there is no remaining +reference to f_spec except from the RULE. + +Now that RULE *might* be useful to an importing module, but that is +purely speculative, and meanwhile the code is taking up space and +codegen time. I found that binary sizes jumped by 6-10% when I +started to specialise INLINE functions (again, Note [Inline +specialisations] in Specialise). + +So it seems better to drop the binding for f_spec, and the rule +itself, if the auto-generated rule is the *only* reason that it is +being kept alive. + +(The RULE still might have been useful in the past; that is, it was +the right thing to have generated it in the first place. See Note +[Inline specialisations] in Specialise. But now it has served its +purpose, and can be discarded.) + +So findExternalRules does this: + * Remove all bindings that are kept alive *only* by isAutoRule rules + (this is done in trim_binds) + * Remove all auto rules that mention bindings that have been removed + (this is done by filtering by keep_rule) + +NB: if a binding is kept alive for some *other* reason (e.g. f_spec is +called in the final code), we keep the rule too. + +This stuff is the only reason for the ru_auto field in a Rule. +-} + +findExternalRules :: Bool -- Omit pragmas + -> [CoreBind] + -> [CoreRule] -- Local rules for imported fns + -> UnfoldEnv -- Ids that are exported, so we need their rules + -> ([CoreBind], [CoreRule]) +-- See Note [Finding external rules] +findExternalRules omit_prags binds imp_id_rules unfold_env + = (trimmed_binds, filter keep_rule all_rules) + where + imp_rules = filter expose_rule imp_id_rules + imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules + + user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet + | otherwise = ruleRhsFreeVars rule + + (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds + + keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs + -- Remove rules that make no sense, because they mention a + -- local binder (on LHS or RHS) that we have now discarded. + -- (NB: ruleFreeVars only includes LocalIds) + -- + -- LHS: we have already filtered out rules that mention internal Ids + -- on LHS but that isn't enough because we might have by now + -- discarded a binding with an external Id. (How? + -- chooseExternalIds is a bit conservative.) + -- + -- RHS: the auto rules that might mention a binder that has + -- been discarded; see Note [Trimming auto-rules] + + expose_rule rule + | omit_prags = False + | otherwise = all is_external_id (ruleLhsFreeIdsList rule) + -- Don't expose a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module). NB: ruleLhsFreeIds only returns LocalIds. + -- See Note [Which rules to expose] + + is_external_id id = case lookupVarEnv unfold_env id of + Just (name, _) -> isExternalName name + Nothing -> False + + trim_binds :: [CoreBind] + -> ( [CoreBind] -- Trimmed bindings + , VarSet -- Binders of those bindings + , VarSet -- Free vars of those bindings + rhs of user rules + -- (we don't bother to delete the binders) + , [CoreRule]) -- All rules, imported + from the bindings + -- This function removes unnecessary bindings, and gathers up rules from + -- the bindings we keep. See Note [Trimming auto-rules] + trim_binds [] -- Base case, start with imp_user_rule_fvs + = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) + + trim_binds (bind:binds) + | any needed bndrs -- Keep binding + = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) + | otherwise -- Discard binding altogether + = stuff + where + stuff@(binds', bndr_set, needed_fvs, rules) + = trim_binds binds + needed bndr = isExportedId bndr || bndr `elemVarSet` needed_fvs + + bndrs = bindersOf bind + rhss = rhssOfBind bind + bndr_set' = bndr_set `extendVarSetList` bndrs + + needed_fvs' = needed_fvs `unionVarSet` + mapUnionVarSet idUnfoldingVars bndrs `unionVarSet` + -- Ignore type variables in the type of bndrs + mapUnionVarSet exprFreeVars rhss `unionVarSet` + mapUnionVarSet user_rule_rhs_fvs local_rules + -- In needed_fvs', we don't bother to delete binders from the fv set + + local_rules = [ rule + | id <- bndrs + , is_external_id id -- Only collect rules for external Ids + , rule <- idCoreRules id + , expose_rule rule ] -- and ones that can fire in a client + +{- +************************************************************************ +* * + tidyTopName +* * +************************************************************************ + +This is where we set names to local/global based on whether they really are +externally visible (see comment at the top of this module). If the name +was previously local, we have to give it a unique occurrence name if +we intend to externalise it. +-} + +tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var maybe_ref occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external + ; return (occ_env', new_external_name) } + + | otherwise = panic "tidyTopName" + where + name = idName id + external = isJust maybe_ref + global = isExternalName name + local = not global + internal = not external + loc = nameSrcSpan name + + old_occ = nameOccName name + new_occ | Just ref <- maybe_ref + , ref /= id + = mkOccName (occNameSpace old_occ) $ + let + ref_str = occNameString (getOccName ref) + occ_str = occNameString old_occ + in + case occ_str of + '$':'w':_ -> occ_str + -- workers: the worker for a function already + -- includes the occname for its parent, so there's + -- no need to prepend the referrer. + _other | isSystemName name -> ref_str + | otherwise -> ref_str ++ '_' : occ_str + -- If this name was system-generated, then don't bother + -- to retain its OccName, just use the referrer. These + -- system-generated names will become "f1", "f2", etc. for + -- a referrer "f". + | otherwise = old_occ + + (occ_env', occ') = tidyOccName occ_env new_occ + + mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) + where + (uniq, us) = takeUniqFromSupply (nsUniqs nc) + + mk_new_external nc = allocateGlobalBinder nc mod occ' loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. + +{- +************************************************************************ +* * +\subsection{Step 2: top-level tidying} +* * +************************************************************************ +-} + +-- TopTidyEnv: when tidying we need to know +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file +-- +-- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- are 'used' +-- +-- * subst_env: A Var->Var mapping that substitutes the new Var for the old + +tidyTopBinds :: HscEnv + -> Module + -> UnfoldEnv + -> TidyOccEnv + -> CoreProgram + -> IO (TidyEnv, CoreProgram) + +tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds + = do mkIntegerId <- lookupMkIntegerName dflags hsc_env + mkNaturalId <- lookupMkNaturalName dflags hsc_env + integerSDataCon <- lookupIntegerSDataConName dflags hsc_env + naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env + let cvt_literal nt i = case nt of + LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i) + LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i) + _ -> Nothing + result = tidy cvt_literal init_env binds + seqBinds (snd result) `seq` return result + -- This seqBinds avoids a spike in space usage (see #13564) + where + dflags = hsc_dflags hsc_env + + init_env = (init_occ_env, emptyVarEnv) + + tidy cvt_literal = mapAccumL (tidyTopBind dflags this_mod cvt_literal unfold_env) + +------------------------ +tidyTopBind :: DynFlags + -> Module + -> (LitNumType -> Integer -> Maybe CoreExpr) + -> UnfoldEnv + -> TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyTopBind dflags this_mod cvt_literal unfold_env + (occ_env,subst1) (NonRec bndr rhs) + = (tidy_env2, NonRec bndr' rhs') + where + Just (name',show_unfold) = lookupVarEnv unfold_env bndr + caf_info = hasCafRefs dflags this_mod + (subst1, cvt_literal) + (idArity bndr) rhs + (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' + (bndr, rhs) + subst2 = extendVarEnv subst1 bndr bndr' + tidy_env2 = (occ_env, subst2) + +tidyTopBind dflags this_mod cvt_literal unfold_env + (occ_env, subst1) (Rec prs) + = (tidy_env2, Rec prs') + where + prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) + | (id,rhs) <- prs, + let (name',show_unfold) = + expectJust "tidyTopBind" $ lookupVarEnv unfold_env id + ] + + subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + tidy_env2 = (occ_env, subst2) + + bndrs = map fst prs + + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + caf_info + | or [ mayHaveCafRefs (hasCafRefs dflags this_mod + (subst1, cvt_literal) + (idArity bndr) rhs) + | (bndr,rhs) <- prs ] = MayHaveCafRefs + | otherwise = NoCafRefs + +----------------------------------------------------------- +tidyTopPair :: DynFlags + -> Bool -- show unfolding + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group + +tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs) + = (bndr1, rhs1) + where + bndr1 = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails + ty' = tidyTopType (idType bndr) + rhs1 = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr) + show_unfold caf_info + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. There are two delicate pieces: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +-- * CAF info. This must also remain valid through to code generation. +-- We add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- CoreToStg makes use of this when constructing SRTs. +tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr + -> IdInfo -> Bool -> CafInfo -> IdInfo +tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig + `setUnfoldingInfo` minimal_unfold_info -- See note [Preserve evaluatedness] + -- in CoreTidy + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setCafInfo` caf_info + `setArityInfo` arity + `setStrictnessInfo` final_sig + `setOccInfo` robust_occ_info + `setInlinePragInfo` (inlinePragInfo idinfo) + `setUnfoldingInfo` unfold_info + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + where + is_external = isExternalName name + + --------- OccInfo ------------ + robust_occ_info = zapFragileOcc (occInfo idinfo) + -- It's important to keep loop-breaker information + -- when we are doing -fexpose-all-unfoldings + + --------- Strictness ------------ + mb_bot_str = exprBotStrictness_maybe orig_rhs + + sig = strictnessInfo idinfo + final_sig | not $ isTopSig sig + = WARN( _bottom_hidden sig , ppr name ) sig + -- try a cheap-and-cheerful bottom analyser + | Just (_, nsig) <- mb_bot_str = nsig + | otherwise = sig + + _bottom_hidden id_sig = case mb_bot_str of + Nothing -> False + Just (arity, _) -> not (appIsBottom id_sig arity) + + --------- Unfolding ------------ + unf_info = unfoldingInfo idinfo + unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs + | otherwise = minimal_unfold_info + minimal_unfold_info = zapUnfolding unf_info + unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs + is_bot = isBottomingSig final_sig + -- NB: do *not* expose the worker if show_unfold is off, + -- because that means this thing is a loop breaker or + -- marked NOINLINE or something like that + -- This is important: if you expose the worker for a loop-breaker + -- then you can make the simplifier go into an infinite loop, because + -- in effect the unfolding is exposed. See #1709 + -- + -- You might think that if show_unfold is False, then the thing should + -- not be w/w'd in the first place. But a legitimate reason is this: + -- the function returns bottom + -- In this case, show_unfold will be false (we don't expose unfoldings + -- for bottoming functions), but we might still have a worker/wrapper + -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs + + + --------- Arity ------------ + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity orig_rhs + +{- +************************************************************************ +* * + Figuring out CafInfo for an expression +* * +************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +Note [Disgusting computation of CafRefs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We compute hasCafRefs here, because IdInfo is supposed to be finalised +after tidying. But CorePrep does some transformations that affect CAF-hood. +So we have to *predict* the result here, which is revolting. + +In particular CorePrep expands Integer and Natural literals. So in the +prediction code here we resort to applying the same expansion (cvt_literal). +There are also numerous other ways in which we can introduce inconsistencies +between CorePrep and GHC.Iface.Tidy. See Note [CAFfyness inconsistencies due to +eta expansion in TidyPgm] for one such example. + +Ugh! What ugliness we hath wrought. + + +Note [CAFfyness inconsistencies due to eta expansion in TidyPgm] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Eta expansion during CorePrep can have non-obvious negative consequences on +the CAFfyness computation done by tidying (see Note [Disgusting computation of +CafRefs] in GHC.Iface.Tidy). This late expansion happens/happened for a few +reasons: + + * CorePrep previously eta expanded unsaturated primop applications, as + described in Note [Primop wrappers]). + + * CorePrep still does eta expand unsaturated data constructor applications. + +In particular, consider the program: + + data Ty = Ty (RealWorld# -> (# RealWorld#, Int #)) + + -- Is this CAFfy? + x :: STM Int + x = Ty (retry# @Int) + +Consider whether x is CAFfy. One might be tempted to answer "no". +Afterall, f obviously has no CAF references and the application (retry# +@Int) is essentially just a variable reference at runtime. + +However, when CorePrep expanded the unsaturated application of 'retry#' +it would rewrite this to + + x = \u [] + let sat = retry# @Int + in Ty sat + +This is now a CAF. Failing to handle this properly was the cause of +#16846. We fixed this by eliminating the need to eta expand primops, as +described in Note [Primop wrappers]), However we have not yet done the same for +data constructor applications. + +-} + +type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr) + -- The env finds the Caf-ness of the Id + -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for + -- Integer and Natural literals + -- See Note [Disgusting computation of CafRefs] + +hasCafRefs :: DynFlags -> Module + -> CafRefEnv -> Arity -> CoreExpr + -> CafInfo +hasCafRefs dflags this_mod (subst, cvt_literal) arity expr + | is_caf || mentions_cafs = MayHaveCafRefs + | otherwise = NoCafRefs + where + mentions_cafs = cafRefsE expr + is_dynamic_name = isDllName dflags this_mod + is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name + cvt_literal expr) + + -- NB. we pass in the arity of the expression, which is expected + -- to be calculated by exprArity. This is because exprArity + -- knows how much eta expansion is going to be done by + -- CorePrep later on, and we don't want to duplicate that + -- knowledge in rhsIsStatic below. + + cafRefsE :: Expr a -> Bool + cafRefsE (Var id) = cafRefsV id + cafRefsE (Lit lit) = cafRefsL lit + cafRefsE (App f a) = cafRefsE f || cafRefsE a + cafRefsE (Lam _ e) = cafRefsE e + cafRefsE (Let b e) = cafRefsEs (rhssOfBind b) || cafRefsE e + cafRefsE (Case e _ _ alts) = cafRefsE e || cafRefsEs (rhssOfAlts alts) + cafRefsE (Tick _n e) = cafRefsE e + cafRefsE (Cast e _co) = cafRefsE e + cafRefsE (Type _) = False + cafRefsE (Coercion _) = False + + cafRefsEs :: [Expr a] -> Bool + cafRefsEs [] = False + cafRefsEs (e:es) = cafRefsE e || cafRefsEs es + + cafRefsL :: Literal -> Bool + -- Don't forget that mk_integer id might have Caf refs! + -- We first need to convert the Integer into its final form, to + -- see whether mkInteger is used. Same for LitNatural. + cafRefsL (LitNumber nt i _) = case cvt_literal nt i of + Just e -> cafRefsE e + Nothing -> False + cafRefsL _ = False + + cafRefsV :: Id -> Bool + cafRefsV id + | not (isLocalId id) = mayHaveCafRefs (idCafInfo id) + | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id') + | otherwise = False + + +{- +************************************************************************ +* * + Old, dead, type-trimming code +* * +************************************************************************ + +We used to try to "trim off" the constructors of data types that are +not exported, to reduce the size of interface files, at least without +-O. But that is not always possible: see the old Note [When we can't +trim types] below for exceptions. + +Then (#7445) I realised that the TH problem arises for any data type +that we have deriving( Data ), because we can invoke + Language.Haskell.TH.Quote.dataToExpQ +to get a TH Exp representation of a value built from that data type. +You don't even need {-# LANGUAGE TemplateHaskell #-}. + +At this point I give up. The pain of trimming constructors just +doesn't seem worth the gain. So I've dumped all the code, and am just +leaving it here at the end of the module in case something like this +is ever resurrected. + + +Note [When we can't trim types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of type trimming is to export algebraic data types +abstractly (without their data constructors) when compiling without +-O, unless of course they are explicitly exported by the user. + +We always export synonyms, because they can be mentioned in the type +of an exported Id. We could do a full dependency analysis starting +from the explicit exports, but that's quite painful, and not done for +now. + +But there are some times we can't do that, indicated by the 'no_trim_types' flag. + +First, Template Haskell. Consider (#2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declaration of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. + +Second, data kinds. Consider (#5912) + {-# LANGUAGE DataKinds #-} + module M() where + data UnaryTypeC a = UnaryDataC a + type Bug = 'UnaryDataC +We always export synonyms, so Bug is exposed, and that means that +UnaryTypeC must be too, even though it's not explicitly exported. In +effect, DataKinds means that we'd need to do a full dependency analysis +to see what data constructors are mentioned. But we don't do that yet. + +In these two cases we just switch off type trimming altogether. + +mustExposeTyCon :: Bool -- Type-trimming flag + -> NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon no_trim_types exports tc + | no_trim_types -- See Note [When we can't trim types] + = True + + | not (isAlgTyCon tc) -- Always expose synonyms (otherwise we'd have to + -- figure out whether it was mentioned in the type + -- of any other exported thing) + = True + + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + + | isFamilyTyCon tc -- Open type family + = True + + -- Below here we just have data/newtype decls or family instances + + | null data_cons -- Ditto if there are no data constructors + = True -- (NB: empty data types do not count as enumerations + -- see Note [Enumeration types] in TyCon + + | any exported_con data_cons -- Expose rep if any datacon or field is exported + = True + + | isNewTyCon tc && isFFITy (snd (newTyConRhs tc)) + = True -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + + | otherwise + = False + where + data_cons = tyConDataCons tc + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) +-} diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs new file mode 100644 index 0000000000..fbabb5b8b5 --- /dev/null +++ b/compiler/GHC/Iface/Type.hs @@ -0,0 +1,2060 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +This module defines interface types and binders +-} + +{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase #-} + -- FlexibleInstances for Binary (DefMethSpec IfaceType) + +module GHC.Iface.Type ( + IfExtName, IfLclName, + + IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), + IfaceMCoercion(..), + IfaceUnivCoProv(..), + IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), + IfaceTyLit(..), IfaceAppArgs(..), + IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, + IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, + IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), + ForallVisFlag(..), ShowForAllFlag(..), + mkIfaceForAllTvBndr, + mkIfaceTyConKind, + + ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, + ifTyConBinderVar, ifTyConBinderName, + + -- Equality testing + isIfaceLiftedTypeKind, + + -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags + appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + + -- Printing + SuppressBndrSig(..), + UseBndrParens(..), + pprIfaceType, pprParendIfaceType, pprPrecIfaceType, + pprIfaceContext, pprIfaceContextArr, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, + pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, + pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, + pprIfaceSigmaType, pprIfaceTyLit, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, + isIfaceTauType, + + suppressIfaceInvisibles, + stripIfaceInvisVars, + stripInvisArgs, + + mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon + , liftedRepDataConTyCon, tupleTyConName ) +import {-# SOURCE #-} Type ( isRuntimeRepTy ) + +import DynFlags +import TyCon hiding ( pprPromotionQuote ) +import CoAxiom +import Var +import PrelNames +import Name +import BasicTypes +import Binary +import Outputable +import FastString +import FastStringEnv +import Util + +import Data.Maybe( isJust ) +import qualified Data.Semigroup as Semi +import Control.DeepSeq + +{- +************************************************************************ +* * + Local (nested) binders +* * +************************************************************************ +-} + +type IfLclName = FastString -- A local name in iface syntax + +type IfExtName = Name -- An External or WiredIn Name can appear in Iface syntax + -- (However Internal or System Names never should) + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr + | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr + +type IfaceIdBndr = (IfLclName, IfaceType) +type IfaceTvBndr = (IfLclName, IfaceKind) + +ifaceTvBndrName :: IfaceTvBndr -> IfLclName +ifaceTvBndrName (n,_) = n + +ifaceIdBndrName :: IfaceIdBndr -> IfLclName +ifaceIdBndrName (n,_) = n + +ifaceBndrName :: IfaceBndr -> IfLclName +ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr +ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr + +ifaceBndrType :: IfaceBndr -> IfaceType +ifaceBndrType (IfaceIdBndr (_, t)) = t +ifaceBndrType (IfaceTvBndr (_, t)) = t + +type IfaceLamBndr = (IfaceBndr, IfaceOneShot) + +data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy + = IfaceNoOneShot -- and Note [The oneShot function] in MkId + | IfaceOneShot + + +{- +%************************************************************************ +%* * + IfaceType +%* * +%************************************************************************ +-} + +------------------------------- +type IfaceKind = IfaceType + +-- | A kind of universal type, used for types and kinds. +-- +-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' +-- before being printed. See Note [Pretty printing via Iface syntax] in PprTyThing +data IfaceType + = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] + | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon + | IfaceLitTy IfaceTyLit + | IfaceAppTy IfaceType IfaceAppArgs + -- See Note [Suppressing invisible arguments] for + -- an explanation of why the second field isn't + -- IfaceType, analogous to AppTy. + | IfaceFunTy AnonArgFlag IfaceType IfaceType + | IfaceForAllTy IfaceForAllBndr IfaceType + | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCastTy IfaceType IfaceCoercion + | IfaceCoercionTy IfaceCoercion + + | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) + TupleSort -- What sort of tuple? + PromotionFlag -- A bit like IfaceTyCon + IfaceAppArgs -- arity = length args + -- For promoted data cons, the kind args are omitted + +type IfacePredType = IfaceType +type IfaceContext = [IfacePredType] + +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit FastString + deriving (Eq) + +type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag + +-- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. +mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis + +-- | Build the 'tyConKind' from the binders and the result kind. +-- Keep in sync with 'mkTyConKind' in types/TyCon. +mkIfaceTyConKind :: [IfaceTyConBinder] -> IfaceKind -> IfaceKind +mkIfaceTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: IfaceTyConBinder -> IfaceKind -> IfaceKind + mk (Bndr tv (AnonTCB af)) k = IfaceFunTy af (ifaceBndrType tv) k + mk (Bndr tv (NamedTCB vis)) k = IfaceForAllTy (Bndr tv vis) k + +-- | Stores the arguments in a type application as a list. +-- See @Note [Suppressing invisible arguments]@. +data IfaceAppArgs + = IA_Nil + | IA_Arg IfaceType -- The type argument + + ArgFlag -- The argument's visibility. We store this here so + -- that we can: + -- + -- 1. Avoid pretty-printing invisible (i.e., specified + -- or inferred) arguments when + -- -fprint-explicit-kinds isn't enabled, or + -- 2. When -fprint-explicit-kinds *is*, enabled, print + -- specified arguments in @(...) and inferred + -- arguments in @{...}. + + IfaceAppArgs -- The rest of the arguments + +instance Semi.Semigroup IfaceAppArgs where + IA_Nil <> xs = xs + IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) + +instance Monoid IfaceAppArgs where + mempty = IA_Nil + mappend = (Semi.<>) + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName + , ifaceTyConInfo :: IfaceTyConInfo } + deriving (Eq) + +-- | The various types of TyCons which have special, built-in syntax. +data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon + + | IfaceTupleTyCon !Arity !TupleSort + -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. + -- The arity is the tuple width, not the tycon arity + -- (which is twice the width in the case of unboxed + -- tuples). + + | IfaceSumTyCon !Arity + -- ^ e.g. @(a | b | c)@ + + | IfaceEqualityTyCon + -- ^ A heterogeneous equality TyCon + -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon) + -- that is actually being applied to two types + -- of the same kind. This affects pretty-printing + -- only: see Note [Equality predicates in IfaceType] + deriving (Eq) + +{- Note [Free tyvars in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to +an IfaceType and pretty printing that. This eliminates a lot of +pretty-print duplication, and it matches what we do with pretty- +printing TyThings. See Note [Pretty printing via Iface syntax] in PprTyThing. + +It works fine for closed types, but when printing debug traces (e.g. +when using -ddump-tc-trace) we print a lot of /open/ types. These +types are full of TcTyVars, and it's absolutely crucial to print them +in their full glory, with their unique, TcTyVarDetails etc. + +So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. +Note that: + +* We never expect to serialise an IfaceFreeTyVar into an interface file, nor + to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType + and then pretty-print" pipeline. + +We do the same for covars, naturally. + +Note [Equality predicates in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has several varieties of type equality (see Note [The equality types story] +in TysPrim for details). In an effort to avoid confusing users, we suppress +the differences during pretty printing unless certain flags are enabled. +Here is how each equality predicate* is printed in homogeneous and +heterogeneous contexts, depending on which combination of the +-fprint-explicit-kinds and -fprint-equality-relations flags is used: + +-------------------------------------------------------------------------------------------- +| Predicate | Neither flag | -fprint-explicit-kinds | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +|-------------------------------|----------------------------|-----------------------------| +| Predicate | -fprint-equality-relations | Both flags | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | +| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +-------------------------------------------------------------------------------------------- + +(* There is no heterogeneous, representational, lifted equality counterpart +to (~~). There could be, but there seems to be no use for it.) + +This table adheres to the following rules: + +A. With -fprint-equality-relations, print the true equality relation. +B. Without -fprint-equality-relations: + i. If the equality is representational and homogeneous, use Coercible. + ii. Otherwise, if the equality is representational, use ~R#. + iii. If the equality is nominal and homogeneous, use ~. + iv. Otherwise, if the equality is nominal, use ~~. +C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, + as above; or print the kind with Coercible. +D. Without -fprint-explicit-kinds, don't print kinds. + +A hetero-kinded equality is used homogeneously when it is applied to two +identical kinds. Unfortunately, determining this from an IfaceType isn't +possible since we can't see through type synonyms. Consequently, we need to +record whether this particular application is homogeneous in IfaceTyConSort +for the purposes of pretty-printing. + +See Note [The equality types story] in TysPrim. +-} + +data IfaceTyConInfo -- Used to guide pretty-printing + -- and to disambiguate D from 'D (they share a name) + = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag + , ifaceTyConSort :: IfaceTyConSort } + deriving (Eq) + +data IfaceMCoercion + = IfaceMRefl + | IfaceMCo IfaceCoercion + +data IfaceCoercion + = IfaceReflCo IfaceType + | IfaceGReflCo Role IfaceType (IfaceMCoercion) + | IfaceFunCo Role IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceAxiomRuleCo IfLclName [IfaceCoercion] + -- There are only a fixed number of CoAxiomRules, so it suffices + -- to use an IfaceLclName to distinguish them. + -- See Note [Adding built-in type families] in TcTypeNats + | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceNthCo Int IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceCoercion + | IfaceKindCo IfaceCoercion + | IfaceSubCo IfaceCoercion + | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] + | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] + +data IfaceUnivCoProv + = IfaceUnsafeCoerceProv + | IfacePhantomProv IfaceCoercion + | IfaceProofIrrelProv IfaceCoercion + | IfacePluginProv String + +{- Note [Holes in IfaceCoercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking fails the typechecker will produce a HoleCo to stand +in place of the unproven assertion. While we generally don't want to +let these unproven assertions leak into interface files, we still need +to be able to pretty-print them as we use IfaceType's pretty-printer +to render Types. For this reason IfaceCoercion has a IfaceHoleCo +constructor; however, we fails when asked to serialize to a +IfaceHoleCo to ensure that they don't end up in an interface file. + + +%************************************************************************ +%* * + Functions over IFaceTypes +* * +************************************************************************ +-} + +ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool +ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key + +isIfaceLiftedTypeKind :: IfaceKind -> Bool +isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) + = isLiftedTypeKindTyConName (ifaceTyConName tc) +isIfaceLiftedTypeKind (IfaceTyConApp tc + (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) + Required IA_Nil)) + = tc `ifaceTyConHasKey` tYPETyConKey + && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey +isIfaceLiftedTypeKind _ = False + +splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) +-- Mainly for printing purposes +-- +-- Here we split nested IfaceSigmaTy properly. +-- +-- @ +-- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b) +-- @ +-- +-- If you called @splitIfaceSigmaTy@ on this type: +-- +-- @ +-- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b)) +-- @ +splitIfaceSigmaTy ty + = case (bndrs, theta) of + ([], []) -> (bndrs, theta, tau) + _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau + in (bndrs ++ bndrs', theta ++ theta', tau') + where + (bndrs, rho) = split_foralls ty + (theta, tau) = split_rho rho + + split_foralls (IfaceForAllTy bndr ty) + = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } + split_foralls rho = ([], rho) + + split_rho (IfaceFunTy InvisArg ty1 ty2) + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho tau = ([], tau) + +suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a] +suppressIfaceInvisibles dflags tys xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) (x:xs) + | isInvisibleTyConBinder k = suppress ks xs + | otherwise = x : suppress ks xs + +stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] +stripIfaceInvisVars dflags tyvars + | gopt Opt_PrintExplicitKinds dflags = tyvars + | otherwise = filterOut isInvisibleTyConBinder tyvars + +-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. +ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr +ifForAllBndrVar = binderVar + +-- | Extract the variable name from an 'IfaceForAllBndr'. +ifForAllBndrName :: IfaceForAllBndr -> IfLclName +ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) + +-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. +ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr +ifTyConBinderVar = binderVar + +-- | Extract the variable name from an 'IfaceTyConBinder'. +ifTyConBinderName :: IfaceTyConBinder -> IfLclName +ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) + +ifTypeIsVarFree :: IfaceType -> Bool +-- Returns True if the type definitely has no variables at all +-- Just used to control pretty printing +ifTypeIsVarFree ty = go ty + where + go (IfaceTyVar {}) = False + go (IfaceFreeTyVar {}) = False + go (IfaceAppTy fun args) = go fun && go_args args + go (IfaceFunTy _ arg res) = go arg && go res + go (IfaceForAllTy {}) = False + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = True + go (IfaceCastTy {}) = False -- Safe + go (IfaceCoercionTy {}) = False -- Safe + + go_args IA_Nil = True + go_args (IA_Arg arg _ args) = go arg && go_args args + +{- Note [Substitution on IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Substitutions on IfaceType are done only during pretty-printing to +construct the result type of a GADT, and does not deal with binders +(eg IfaceForAll), so it doesn't need fancy capture stuff. -} + +type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] + +mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst +-- See Note [Substitution on IfaceType] +mkIfaceTySubst eq_spec = mkFsEnv eq_spec + +inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool +-- See Note [Substitution on IfaceType] +inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +-- See Note [Substitution on IfaceType] +substIfaceType env ty + = go ty + where + go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) + go (IfaceFunTy af t1 t2) = IfaceFunTy af (go t1) (go t2) + go ty@(IfaceLitTy {}) = ty + go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) + go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) + go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) + go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) + + go_mco IfaceMRefl = IfaceMRefl + go_mco (IfaceMCo co) = IfaceMCo $ go_co co + + go_co (IfaceReflCo ty) = IfaceReflCo (go ty) + go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) + go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) + go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) + go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) + go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) + go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv + go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv + go_co (IfaceHoleCo cv) = IfaceHoleCo cv + go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) + go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) + go_co (IfaceSymCo co) = IfaceSymCo (go_co co) + go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) + go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) + go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) + go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) + go_co (IfaceKindCo co) = IfaceKindCo (go_co co) + go_co (IfaceSubCo co) = IfaceSubCo (go_co co) + go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) + + go_cos = map go_co + + go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv + go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) + go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) + go_prov (IfacePluginProv str) = IfacePluginProv str + +substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs +substIfaceAppArgs env args + = go args + where + go IA_Nil = IA_Nil + go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env tv = ty + | otherwise = IfaceTyVar tv + + +{- +************************************************************************ +* * + Functions over IfaceAppArgs +* * +************************************************************************ +-} + +stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs +stripInvisArgs dflags tys + | gopt Opt_PrintExplicitKinds dflags = tys + | otherwise = suppress_invis tys + where + suppress_invis c + = case c of + IA_Nil -> IA_Nil + IA_Arg t argf ts + | isVisibleArgFlag argf + -> IA_Arg t argf $ suppress_invis ts + -- Keep recursing through the remainder of the arguments, as it's + -- possible that there are remaining invisible ones. + -- See the "In type declarations" section of Note [VarBndrs, + -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. + | otherwise + -> suppress_invis ts + +appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] +appArgsIfaceTypes IA_Nil = [] +appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts + +appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] +appArgsIfaceTypesArgFlags IA_Nil = [] +appArgsIfaceTypesArgFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesArgFlags ts + +ifaceVisAppArgsLength :: IfaceAppArgs -> Int +ifaceVisAppArgsLength = go 0 + where + go !n IA_Nil = n + go n (IA_Arg _ argf rest) + | isVisibleArgFlag argf = go (n+1) rest + | otherwise = go n rest + +{- +Note [Suppressing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceAppArgs data type to specify which of the arguments to a type +should be displayed when pretty-printing, under the control of +-fprint-explicit-kinds. +See also Type.filterOutInvisibleTypes. +For example, given + + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted + +we want + + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + +For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, +since the corresponding Core constructor: + + data Type + = ... + | TyConApp TyCon [Type] + +Already puts all of its arguments into a list. So when converting a Type to an +IfaceType (see toIfaceAppArgsX in GHC.Core.ToIface), we simply use the kind of +the TyCon (which is cached) to guide the process of converting the argument +Types into an IfaceAppArgs list. + +We also want this behavior for IfaceAppTy, since given: + + data Proxy (a :: k) + f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) + +We want to print the return type as `Proxy (t True)` without the use of +-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the +tycon case, because the corresponding Core constructor for IfaceAppTy: + + data Type + = ... + | AppTy Type Type + +Only stores one argument at a time. Therefore, when converting an AppTy to an +IfaceAppTy (in toIfaceTypeX in GHC.CoreToIface), we: + +1. Flatten the chain of AppTys down as much as possible +2. Use typeKind to determine the function Type's kind +3. Use this kind to guide the process of converting the argument Types into an + IfaceAppArgs list. + +By flattening the arguments like this, we obtain two benefits: + +(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as + we do IfaceTyApp arguments, which means that we only need to implement the + logic to filter out invisible arguments once. +(b) Unlike for tycons, finding the kind of a type in general (through typeKind) + is not a constant-time operation, so by flattening the arguments first, we + decrease the number of times we have to call typeKind. + +Note [Pretty-printing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] is all about how to avoid printing +invisible arguments when the -fprint-explicit-kinds flag is disables. Well, +what about when it's enabled? Then we can and should print invisible kind +arguments, and this Note explains how we do it. + +As two running examples, consider the following code: + + {-# LANGUAGE PolyKinds #-} + data T1 a + data T2 (a :: k) + +When displaying these types (with -fprint-explicit-kinds on), we could just +do the following: + + T1 k a + T2 k a + +That certainly gets the job done. But it lacks a crucial piece of information: +is the `k` argument inferred or specified? To communicate this, we use visible +kind application syntax to distinguish the two cases: + + T1 @{k} a + T2 @k a + +Here, @{k} indicates that `k` is an inferred argument, and @k indicates that +`k` is a specified argument. (See +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for +a lengthier explanation on what "inferred" and "specified" mean.) + +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +if_print_coercions :: SDoc -- ^ if printing coercions + -> SDoc -- ^ otherwise + -> SDoc +if_print_coercions yes no + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + if gopt Opt_PrintExplicitCoercions dflags + || dumpStyle style || debugStyle style + then yes + else no + +pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc +pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 + = maybeParen ctxt_prec opPrec $ + sep [pp_ty1, pp_tc <+> pp_ty2] + +pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp ctxt_prec pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen ctxt_prec appPrec $ + hang pp_fun 2 (sep pp_tys) + +isIfaceTauType :: IfaceType -> Bool +isIfaceTauType (IfaceForAllTy _ _) = False +isIfaceTauType (IfaceFunTy InvisArg _ _) = False +isIfaceTauType _ = True + +-- ----------------------------- Printing binders ------------------------------------ + +instance Outputable IfaceBndr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr (SuppressBndrSig False) + (UseBndrParens False) + +pprIfaceBndrs :: [IfaceBndr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceLamBndr :: IfaceLamBndr -> SDoc +pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b +pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" + +pprIfaceIdBndr :: IfaceIdBndr -> SDoc +pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) + +{- Note [Suppressing binder signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When printing the binders in a 'forall', we want to keep the kind annotations: + + forall (a :: k). blah + ^^^^ + good + +On the other hand, when we print the binders of a data declaration in :info, +the kind information would be redundant due to the standalone kind signature: + + type F :: Symbol -> Type + type F (s :: Symbol) = blah + ^^^^^^^^^ + redundant + +Here we'd like to omit the kind annotation: + + type F :: Symbol -> Type + type F s = blah +-} + +-- | Do we want to suppress kind annotations on binders? +-- See Note [Suppressing binder signatures] +newtype SuppressBndrSig = SuppressBndrSig Bool + +newtype UseBndrParens = UseBndrParens Bool + +pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc +pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens) + | suppress_sig = ppr tv + | isIfaceLiftedTypeKind ki = ppr tv + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) + where + maybe_parens | use_parens = parens + | otherwise = id + +pprIfaceTyConBinders :: SuppressBndrSig -> [IfaceTyConBinder] -> SDoc +pprIfaceTyConBinders suppress_sig = sep . map go + where + go :: IfaceTyConBinder -> SDoc + go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr + go (Bndr (IfaceTvBndr bndr) vis) = + -- See Note [Pretty-printing invisible arguments] + case vis of + AnonTCB VisArg -> ppr_bndr (UseBndrParens True) + AnonTCB InvisArg -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + -- The above case is rare. (See Note [AnonTCB InvisArg] in TyCon.) + -- Should we print these differently? + NamedTCB Required -> ppr_bndr (UseBndrParens True) + NamedTCB Specified -> char '@' <> ppr_bndr (UseBndrParens True) + NamedTCB Inferred -> char '@' <> braces (ppr_bndr (UseBndrParens False)) + where + ppr_bndr = pprIfaceTvBndr bndr suppress_sig + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) + +instance Binary IfaceOneShot where + put_ bh IfaceNoOneShot = do + putByte bh 0 + put_ bh IfaceOneShot = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return IfaceNoOneShot + _ -> do return IfaceOneShot + +-- ----------------------------- Printing IfaceType ------------------------------------ + +--------------------------------- +instance Outputable IfaceType where + ppr ty = pprIfaceType ty + +pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc +pprIfaceType = pprPrecIfaceType topPrec +pprParendIfaceType = pprPrecIfaceType appPrec + +pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc +-- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe +-- called from other places, besides `:type` and `:info`. +pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty + +ppr_sigma :: PprPrec -> IfaceType -> SDoc +ppr_sigma ctxt_prec ty + = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) + +ppr_ty :: PprPrec -> IfaceType -> SDoc +ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty +ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _) = ppr_sigma ctxt_prec ty + +ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys +ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys +ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n + -- Function types +ppr_ty ctxt_prec (IfaceFunTy _ ty1 ty2) -- Should be VisArg + = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + maybeParen ctxt_prec funPrec $ + sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)] + where + ppr_fun_tail (IfaceFunTy VisArg ty1 ty2) + = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2 + ppr_fun_tail other_ty + = [arrow <+> pprIfaceType other_ty] + +ppr_ty ctxt_prec (IfaceAppTy t ts) + = if_print_coercions + ppr_app_ty + ppr_app_ty_no_casts + where + ppr_app_ty = + sdocWithDynFlags $ \dflags -> + pprIfacePrefixApp ctxt_prec + (ppr_ty funPrec t) + (map (ppr_app_arg appPrec) (tys_wo_kinds dflags)) + + tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts + + -- Strip any casts from the head of the application + ppr_app_ty_no_casts = + case t of + IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) + _ -> ppr_app_ty + + mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType + mk_app_tys (IfaceTyConApp tc tys1) tys2 = + IfaceTyConApp tc (tys1 `mappend` tys2) + mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 + +ppr_ty ctxt_prec (IfaceCastTy ty co) + = if_print_coercions + (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) + (ppr_ty ctxt_prec ty) + +ppr_ty ctxt_prec (IfaceCoercionTy co) + = if_print_coercions + (ppr_co ctxt_prec co) + (text "<>") + +{- Note [Defaulting RuntimeRep variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RuntimeRep variables are considered by many (most?) users to be little +more than syntactic noise. When the notion was introduced there was a +significant and understandable push-back from those with pedagogy in +mind, which argued that RuntimeRep variables would throw a wrench into +nearly any teach approach since they appear in even the lowly ($) +function's type, + + ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b + +which is significantly less readable than its non RuntimeRep-polymorphic type of + + ($) :: (a -> b) -> a -> b + +Moreover, unboxed types don't appear all that often in run-of-the-mill +Haskell programs, so it makes little sense to make all users pay this +syntactic overhead. + +For this reason it was decided that we would hide RuntimeRep variables +for now (see #11549). We do this by defaulting all type variables of +kind RuntimeRep to LiftedRep. This is done in a pass right before +pretty-printing (defaultRuntimeRepVars, controlled by +-fprint-explicit-runtime-reps) + +This applies to /quantified/ variables like 'w' above. What about +variables that are /free/ in the type being printed, which certainly +happens in error messages. Suppose (#16074) we are reporting a +mismatch between two skolems + (a :: RuntimeRep) ~ (b :: RuntimeRep) +We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"! + +But if we are printing the type + (forall (a :: Type r). blah +we do want to turn that (free) r into LiftedRep, so it prints as + (forall a. blah) + +Conclusion: keep track of whether we we are in the kind of a +binder; ohly if so, convert free RuntimeRep variables to LiftedRep. +-} + +-- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. +-- +-- @ +-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). +-- (a -> b) -> a -> b +-- @ +-- +-- turns in to, +-- +-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- +-- We do this to prevent RuntimeRep variables from incurring a significant +-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See +-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. +-- +defaultRuntimeRepVars :: IfaceType -> IfaceType +defaultRuntimeRepVars ty = go False emptyFsEnv ty + where + go :: Bool -- True <=> Inside the kind of a binder + -> FastStringEnv () -- Set of enclosing forall-ed RuntimeRep variables + -> IfaceType -- (replace them with LiftedRep) + -> IfaceType + go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) + | isRuntimeRep var_kind + , isInvisibleArgFlag argf -- Don't default *visible* quantification + -- or we get the mess in #13963 + = let subs' = extendFsEnv subs var () + -- Record that we should replace it with LiftedRep, + -- and recurse, discarding the forall + in go ink subs' ty + + go ink subs (IfaceForAllTy bndr ty) + = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty) + + go _ subs ty@(IfaceTyVar tv) + | tv `elemFsEnv` subs + = IfaceTyConApp liftedRep IA_Nil + | otherwise + = ty + + go in_kind _ ty@(IfaceFreeTyVar tv) + -- See Note [Defaulting RuntimeRep variables], about free vars + | in_kind && Type.isRuntimeRepTy (tyVarKind tv) + = IfaceTyConApp liftedRep IA_Nil + | otherwise + = ty + + go ink subs (IfaceTyConApp tc tc_args) + = IfaceTyConApp tc (go_args ink subs tc_args) + + go ink subs (IfaceTupleTy sort is_prom tc_args) + = IfaceTupleTy sort is_prom (go_args ink subs tc_args) + + go ink subs (IfaceFunTy af arg res) + = IfaceFunTy af (go ink subs arg) (go ink subs res) + + go ink subs (IfaceAppTy t ts) + = IfaceAppTy (go ink subs t) (go_args ink subs ts) + + go ink subs (IfaceCastTy x co) + = IfaceCastTy (go ink subs x) co + + go _ _ ty@(IfaceLitTy {}) = ty + go _ _ ty@(IfaceCoercionTy {}) = ty + + go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr + go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf) + = Bndr (IfaceIdBndr (n, go True subs t)) argf + go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) + = Bndr (IfaceTvBndr (n, go True subs t)) argf + + go_args :: Bool -> FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs + go_args _ _ IA_Nil = IA_Nil + go_args ink subs (IA_Arg ty argf args) + = IA_Arg (go ink subs ty) argf (go_args ink subs args) + + liftedRep :: IfaceTyCon + liftedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) + where dc_name = getName liftedRepDataConTyCon + + isRuntimeRep :: IfaceType -> Bool + isRuntimeRep (IfaceTyConApp tc _) = + tc `ifaceTyConHasKey` runtimeRepTyConKey + isRuntimeRep _ = False + +eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc +eliminateRuntimeRep f ty + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \sty -> + if userStyle sty && not (gopt Opt_PrintExplicitRuntimeReps dflags) + then f (defaultRuntimeRepVars ty) + else f ty + +instance Outputable IfaceAppArgs where + ppr tca = pprIfaceAppArgs tca + +pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc +pprIfaceAppArgs = ppr_app_args topPrec +pprParendIfaceAppArgs = ppr_app_args appPrec + +ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc +ppr_app_args ctx_prec = go + where + go :: IfaceAppArgs -> SDoc + go IA_Nil = empty + go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts + +-- See Note [Pretty-printing invisible arguments] +ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc +ppr_app_arg ctx_prec (t, argf) = + sdocWithDynFlags $ \dflags -> + let print_kinds = gopt Opt_PrintExplicitKinds dflags + in case argf of + Required -> ppr_ty ctx_prec t + Specified | print_kinds + -> char '@' <> ppr_ty appPrec t + Inferred | print_kinds + -> char '@' <> braces (ppr_ty topPrec t) + _ -> empty + +------------------- +pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc + +-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. +pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPartMust tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc + +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc +pprIfaceForAllCoPart tvs sdoc + = sep [ pprIfaceForAllCo tvs, sdoc ] + +ppr_iface_forall_part :: ShowForAllFlag + -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +ppr_iface_forall_part show_forall tvs ctxt sdoc + = sep [ case show_forall of + ShowForAllMust -> pprIfaceForAll tvs + ShowForAllWhen -> pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll bndrs@(Bndr _ vis : _) + = sep [ add_separator (forAllLit <+> fsep docs) + , pprIfaceForAll bndrs' ] + where + (bndrs', docs) = ppr_itv_bndrs bndrs vis + + add_separator stuff = case vis of + Required -> stuff <+> arrow + _inv -> stuff <> dot + + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_itv_bndrs :: [IfaceForAllBndr] + -> ArgFlag -- ^ visibility of the first binder in the list + -> ([IfaceForAllBndr], [SDoc]) +ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 + | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) +ppr_itv_bndrs [] _ = ([], []) + +pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCo [] = empty +pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot + +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs + +pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc +pprIfaceForAllBndr bndr = + case bndr of + Bndr (IfaceTvBndr tv) Inferred -> + sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitForalls dflags + then braces $ pprIfaceTvBndr tv suppress_sig (UseBndrParens False) + else pprIfaceTvBndr tv suppress_sig (UseBndrParens True) + Bndr (IfaceTvBndr tv) _ -> + pprIfaceTvBndr tv suppress_sig (UseBndrParens True) + Bndr (IfaceIdBndr idv) _ -> pprIfaceIdBndr idv + where + -- See Note [Suppressing binder signatures] + suppress_sig = SuppressBndrSig False + +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co) + = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) + +-- | Show forall flag +-- +-- Unconditionally show the forall quantifier with ('ShowForAllMust') +-- or when ('ShowForAllWhen') the names used are free in the binder +-- or when compiling with -fprint-explicit-foralls. +data ShowForAllFlag = ShowForAllMust | ShowForAllWhen + +pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc +pprIfaceSigmaType show_forall ty + = eliminateRuntimeRep ppr_fn ty + where + ppr_fn iface_ty = + let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty + in ppr_iface_forall_part show_forall tvs theta (ppr tau) + +pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocWithDynFlags $ \dflags -> + -- See Note [When to print foralls] in this module. + ppWhen (any tv_has_kind_var tvs + || any tv_is_required tvs + || gopt Opt_PrintExplicitForalls dflags) $ + pprIfaceForAll tvs + where + tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) + = not (ifTypeIsVarFree kind) + tv_has_kind_var _ = False + + tv_is_required = isVisibleArgFlag . binderArgFlag + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We opt to explicitly pretty-print `forall`s if any of the following +criteria are met: + +1. -fprint-explicit-foralls is on. + +2. A bound type variable has a polymorphic kind. E.g., + + forall k (a::k). Proxy a -> Proxy a + + Since a's kind mentions a variable k, we print the foralls. + +3. A bound type variable is a visible argument (#14238). + Suppose we are printing the kind of: + + T :: forall k -> k -> Type + + The "forall k ->" notation means that this kind argument is required. + That is, it must be supplied at uses of T. E.g., + + f :: T (Type->Type) Monad -> Int + + So we print an explicit "T :: forall k -> k -> Type", + because omitting it and printing "T :: k -> Type" would be + utterly misleading. + + See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + in TyCoRep. + +N.B. Until now (Aug 2018) we didn't check anything for coercion variables. + +Note [Printing foralls in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the same criteria as in Note [When to print foralls] to determine +whether a type family instance should be pretty-printed with an explicit +`forall`. Example: + + type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo (a :: Type) = Int + Foo a = a + +Without -fprint-explicit-foralls enabled, this will be pretty-printed as: + +type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo a = Int + forall k (a :: k). Foo a = a + +Note that only the third equation has an explicit forall, since it has a type +variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then +the second equation would be preceded with `forall a.`.) + +There is one tricky point in the implementation: what visibility +do we give the type variables in a type family instance? Type family instances +only store type *variables*, not type variable *binders*, and only the latter +has visibility information. We opt to default the visibility of each of these +type variables to Specified because users can't ever instantiate these +variables manually, so the choice of visibility is only relevant to +pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is +printed the way it is, even though it wasn't written explicitly in the +original source code.) + +We adopt the same strategy for data family instances. Example: + + data family DF (a :: k) + data instance DF '[a, b] = DFList + +That data family instance is pretty-printed as: + + data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList + +This is despite that the representation tycon for this data instance (call it +$DF:List) actually has different visibilities for its binders. +However, the visibilities of these binders are utterly irrelevant to the +programmer, who cares only about the specificity of variables in `DF`'s type, +not $DF:List's type. Therefore, we opt to pretty-print all variables in data +family instances as Specified. + +Note [Printing promoted type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi session (#14343) + > _ :: Proxy '[ 'True ] + error: + Found hole: _ :: Proxy '['True] + +This would be bad, because the '[' looks like a character literal. +Solution: in type-level lists and tuples, add a leading space +if the first type is itself promoted. See pprSpaceIfPromotedTyCon. +-} + + +------------------- + +-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. +-- See Note [Printing promoted type constructors] +pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc +pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) + = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of + IsPromoted -> (space <>) + _ -> id +pprSpaceIfPromotedTyCon _ + = id + +-- See equivalent function in TyCoRep.hs +pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep + (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) + 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tc `ifaceTyConHasKey` consDataConKey + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `ifaceTyConHasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args + +pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprTyTcApp ctxt_prec tc tys = + sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + pprTyTcApp' ctxt_prec tc tys dflags style + +pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs + -> DynFlags -> PprStyle -> SDoc +pprTyTcApp' ctxt_prec tc tys dflags style + | ifaceTyConName tc `hasKey` ipClassKey + , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) + Required (IA_Arg ty Required IA_Nil) <- tys + = maybeParen ctxt_prec funPrec + $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty + + | IfaceTupleTyCon arity sort <- ifaceTyConSort info + , not (debugStyle style) + , arity == ifaceVisAppArgsLength tys + = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys + + | IfaceSumTyCon arity <- ifaceTyConSort info + = pprSum arity (ifaceTyConIsPromoted info) tys + + | tc `ifaceTyConHasKey` consDataConKey + , not (gopt Opt_PrintExplicitKinds dflags) + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + = pprIfaceTyList ctxt_prec ty1 ty2 + + | tc `ifaceTyConHasKey` tYPETyConKey + , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys + , rep `ifaceTyConHasKey` liftedRepDataConKey + = ppr_kind_type ctxt_prec + + | otherwise + = getPprDebug $ \dbg -> + if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey + -- Suppress detail unless you _really_ want to see + -> text "(TypeError ...)" + + | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) + -> doc + + | otherwise + -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds + where + info = ifaceTyConInfo tc + tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys + +ppr_kind_type :: PprPrec -> SDoc +ppr_kind_type ctxt_prec = + sdocWithDynFlags $ \dflags -> + if useStarIsType dflags + then maybeParen ctxt_prec starPrec $ + unicodeSyntax (char '★') (char '*') + else text "Type" + +-- | Pretty-print a type-level equality. +-- Returns (Just doc) if the argument is a /saturated/ application +-- of eqTyCon (~) +-- eqPrimTyCon (~#) +-- eqReprPrimTyCon (~R#) +-- heqTyCon (~~) +-- +-- See Note [Equality predicates in IfaceType] +-- and Note [The equality types story] in TysPrim +ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc +ppr_equality ctxt_prec tc args + | hetero_eq_tc + , [k1, k2, t1, t2] <- args + = Just $ print_equality (k1, k2, t1, t2) + + | hom_eq_tc + , [k, t1, t2] <- args + = Just $ print_equality (k, k, t1, t2) + + | otherwise + = Nothing + where + homogeneous = tc_name `hasKey` eqTyConKey -- (~) + || hetero_tc_used_homogeneously + where + hetero_tc_used_homogeneously + = case ifaceTyConSort $ ifaceTyConInfo tc of + IfaceEqualityTyCon -> True + _other -> False + -- True <=> a heterogeneous equality whose arguments + -- are (in this case) of the same kind + + tc_name = ifaceTyConName tc + pp = ppr_ty + hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) + hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) + || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) + || tc_name `hasKey` heqTyConKey -- (~~) + nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) + || tc_name `hasKey` eqPrimTyConKey -- (~#) + print_equality args = + sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + print_equality' args style dflags + + print_equality' (ki1, ki2, ty1, ty2) style dflags + | -- If -fprint-equality-relations is on, just print the original TyCon + print_eqs + = ppr_infix_eq (ppr tc) + + | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) + -- or unlifted equality (ty1 ~# ty2) + nominal_eq_tc, homogeneous + = ppr_infix_eq (text "~") + + | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) + not homogeneous + = ppr_infix_eq (ppr heqTyCon) + + | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) + tc_name `hasKey` eqReprPrimTyConKey, homogeneous + = let ki | print_kinds = [pp appPrec ki1] + | otherwise = [] + in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) + (ki ++ [pp appPrec ty1, pp appPrec ty2]) + + -- The other cases work as you'd expect + | otherwise + = ppr_infix_eq (ppr tc) + where + ppr_infix_eq :: SDoc -> SDoc + ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op + (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) + where + pp_ty_ki ty ki + | print_kinds + = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) + | otherwise + = pp opPrec ty + + print_kinds = gopt Opt_PrintExplicitKinds dflags + print_eqs = gopt Opt_PrintEqualityRelations dflags || + dumpStyle style || debugStyle style + + +pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = + ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc + (map (, Required) tys) + -- We are trying to re-use ppr_iface_tc_app here, which requires its + -- arguments to be accompanied by visibilities. But visibility is + -- irrelevant when printing coercions, so just default everything to + -- Required. + +-- | Pretty-prints an application of a type constructor to some arguments +-- (whose visibilities are known). This is polymorphic (over @a@) since we use +-- this function to pretty-print two different things: +-- +-- 1. Types (from `pprTyTcApp'`) +-- +-- 2. Coercions (from 'pprIfaceCoTcApp') +ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) + +ppr_iface_tc_app pp ctxt_prec tc tys + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + = ppr_kind_type ctxt_prec + + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + + | [ ty1@(_, Required) + , ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + = pprIfaceInfixApp ctxt_prec (ppr tc) + (pp opPrec ty1) (pp opPrec ty2) + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + +pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc +pprSum _arity is_promoted args + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + in pprPromotionQuoteI is_promoted + <> sumParens (pprWithBars (ppr_ty topPrec) args') + +pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc +pprTuple ctxt_prec sort promoted args = + case promoted of + IsPromoted + -> let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + spaceIfPromoted = case args' of + arg0:_ -> pprSpaceIfPromotedTyCon arg0 + _ -> id + in ppr_tuple_app args' $ + pprPromotionQuoteI IsPromoted <> + tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) + + NotPromoted + | ConstraintTuple <- sort + , IA_Nil <- args + -> maybeParen ctxt_prec sigPrec $ + text "() :: Constraint" + + | otherwise + -> -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + let tys = appArgsIfaceTypes args + args' = case sort of + UnboxedTuple -> drop (length tys `div` 2) tys + _ -> tys + in + ppr_tuple_app args' $ + pprPromotionQuoteI promoted <> + tupleParens sort (pprWithCommas pprIfaceType args') + where + ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc + ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens + -- Special-case unary boxed tuples so that they are pretty-printed as + -- `Unit x`, not `(x)` + | [_] <- args_wo_runtime_reps + , BoxedTuple <- sort + = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon + unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in + pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args + | otherwise + = ppr_args_w_parens + +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceTyLit (IfaceNumTyLit n) = integer n +pprIfaceTyLit (IfaceStrTyLit n) = text (show n) + +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc +pprIfaceCoercion = ppr_co topPrec +pprParendIfaceCoercion = ppr_co appPrec + +ppr_co :: PprPrec -> IfaceCoercion -> SDoc +ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal +ppr_co _ (IfaceGReflCo r ty IfaceMRefl) + = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) + = ppr_special_co ctxt_prec + (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] +ppr_co ctxt_prec (IfaceFunCo r co1 co2) + = maybeParen ctxt_prec funPrec $ + sep (ppr_co funPrec co1 : ppr_fun_tail co2) + where + ppr_fun_tail (IfaceFunCo r co1 co2) + = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2 + ppr_fun_tail other_co + = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec appPrec $ + ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo {}) + = maybeParen ctxt_prec funPrec $ + pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) + where + (tvs, inner_co) = split_co co + + split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co co' = ([], co') + +-- Why these three? See Note [TcTyVars in IfaceType] +ppr_co _ (IfaceFreeCoVar covar) = ppr covar +ppr_co _ (IfaceCoVarCo covar) = ppr covar +ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) + +ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) + = maybeParen ctxt_prec appPrec $ + text "UnsafeCo" <+> ppr r <+> + pprParendIfaceType ty1 <+> pprParendIfaceType ty2 + +ppr_co _ (IfaceUnivCo prov role ty1 ty2) + = text "Univ" <> (parens $ + sep [ ppr role <+> pprIfaceUnivCoProv prov + , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec appPrec $ + text "Inst" <+> pprParendIfaceCoercion co + <+> pprParendIfaceCoercion ty + +ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) + = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) + +ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) + = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos +ppr_co ctxt_prec (IfaceSymCo co) + = ppr_special_co ctxt_prec (text "Sym") [co] +ppr_co ctxt_prec (IfaceTransCo co1 co2) + = maybeParen ctxt_prec opPrec $ + ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2 +ppr_co ctxt_prec (IfaceNthCo d co) + = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] +ppr_co ctxt_prec (IfaceLRCo lr co) + = ppr_special_co ctxt_prec (ppr lr) [co] +ppr_co ctxt_prec (IfaceSubCo co) + = ppr_special_co ctxt_prec (text "Sub") [co] +ppr_co ctxt_prec (IfaceKindCo co) + = ppr_special_co ctxt_prec (text "Kind") [co] + +ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec appPrec + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +------------------ +pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc +pprIfaceUnivCoProv IfaceUnsafeCoerceProv + = text "unsafe" +pprIfaceUnivCoProv (IfacePhantomProv co) + = text "phantom" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfaceProofIrrelProv co) + = text "irrel" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfacePluginProv s) + = text "plugin" <+> doubleQuotes (text s) + +------------------- +instance Outputable IfaceTyCon where + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote tc = + pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc + +pprPromotionQuoteI :: PromotionFlag -> SDoc +pprPromotionQuoteI NotPromoted = empty +pprPromotionQuoteI IsPromoted = char '\'' + +instance Outputable IfaceCoercion where + ppr = pprIfaceCoercion + +instance Binary IfaceTyCon where + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + + get bh = do n <- get bh + i <- get bh + return (IfaceTyCon n i) + +instance Binary IfaceTyConSort where + put_ bh IfaceNormalTyCon = putByte bh 0 + put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort + put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity + put_ bh IfaceEqualityTyCon = putByte bh 3 + + get bh = do + n <- getByte bh + case n of + 0 -> return IfaceNormalTyCon + 1 -> IfaceTupleTyCon <$> get bh <*> get bh + 2 -> IfaceSumTyCon <$> get bh + _ -> return IfaceEqualityTyCon + +instance Binary IfaceTyConInfo where + put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s + + get bh = IfaceTyConInfo <$> get bh <*> get bh + +instance Outputable IfaceTyLit where + ppr = pprIfaceTyLit + +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +instance Binary IfaceAppArgs where + put_ bh tk = + case tk of + IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts + IA_Nil -> putByte bh 1 + + get bh = + do c <- getByte bh + case c of + 0 -> do + t <- get bh + a <- get bh + ts <- get bh + return $! IA_Arg t a ts + 1 -> return IA_Nil + _ -> panic ("get IfaceAppArgs " ++ show c) + +------------------- + +-- Some notes about printing contexts +-- +-- In the event that we are printing a singleton context (e.g. @Eq a@) we can +-- omit parentheses. However, we must take care to set the precedence correctly +-- to opPrec, since something like @a :~: b@ must be parenthesized (see +-- #9658). +-- +-- When printing a larger context we use 'fsep' instead of 'sep' so that +-- the context doesn't get displayed as a giant column. Rather than, +-- instance (Eq a, +-- Eq b, +-- Eq c, +-- Eq d, +-- Eq e, +-- Eq f, +-- Eq g, +-- Eq h, +-- Eq i, +-- Eq j, +-- Eq k, +-- Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) +-- +-- we want +-- +-- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, +-- Eq j, Eq k, Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + + + +-- | Prints "(C a, D b) =>", including the arrow. +-- Used when we want to print a context in a type, so we +-- use 'funPrec' to decide whether to parenthesise a singleton +-- predicate; e.g. Num a => a -> a +pprIfaceContextArr :: [IfacePredType] -> SDoc +pprIfaceContextArr [] = empty +pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow +pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow + +-- | Prints a context or @()@ if empty +-- You give it the context precedence +pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc +pprIfaceContext _ [] = text "()" +pprIfaceContext prec [pred] = ppr_ty prec pred +pprIfaceContext _ preds = ppr_parend_preds preds + +ppr_parend_preds :: [IfacePredType] -> SDoc +ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ _ (IfaceFreeTyVar tv) + = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) + + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy af ag ah) = do + putByte bh 3 + put_ bh af + put_ bh ag + put_ bh ah + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } + put_ bh (IfaceCastTy a b) + = do { putByte bh 6; put_ bh a; put_ bh b } + put_ bh (IfaceCoercionTy a) + = do { putByte bh 7; put_ bh a } + put_ bh (IfaceTupleTy s i tys) + = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } + put_ bh (IfaceLitTy n) + = do { putByte bh 9; put_ bh n } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do af <- get bh + ag <- get bh + ah <- get bh + return (IfaceFunTy af ag ah) + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + 6 -> do { a <- get bh; b <- get bh + ; return (IfaceCastTy a b) } + 7 -> do { a <- get bh + ; return (IfaceCoercionTy a) } + + 8 -> do { s <- get bh; i <- get bh; tys <- get bh + ; return (IfaceTupleTy s i tys) } + _ -> do n <- get bh + return (IfaceLitTy n) + +instance Binary IfaceMCoercion where + put_ bh IfaceMRefl = do + putByte bh 1 + put_ bh (IfaceMCo co) = do + putByte bh 2 + put_ bh co + + get bh = do + tag <- getByte bh + case tag of + 1 -> return IfaceMRefl + 2 -> do a <- get bh + return $ IfaceMCo a + _ -> panic ("get IfaceMCoercion " ++ show tag) + +instance Binary IfaceCoercion where + put_ bh (IfaceReflCo a) = do + putByte bh 1 + put_ bh a + put_ bh (IfaceGReflCo a b c) = do + putByte bh 2 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceFunCo a b c) = do + putByte bh 3 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceTyConAppCo a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceAppCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceForAllCo a b c) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceCoVarCo a) = do + putByte bh 7 + put_ bh a + put_ bh (IfaceAxiomInstCo a b c) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceUnivCo a b c d) = do + putByte bh 9 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfaceSymCo a) = do + putByte bh 10 + put_ bh a + put_ bh (IfaceTransCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceNthCo a b) = do + putByte bh 12 + put_ bh a + put_ bh b + put_ bh (IfaceLRCo a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceInstCo a b) = do + putByte bh 14 + put_ bh a + put_ bh b + put_ bh (IfaceKindCo a) = do + putByte bh 15 + put_ bh a + put_ bh (IfaceSubCo a) = do + putByte bh 16 + put_ bh a + put_ bh (IfaceAxiomRuleCo a b) = do + putByte bh 17 + put_ bh a + put_ bh b + put_ _ (IfaceFreeCoVar cv) + = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) + put_ _ (IfaceHoleCo cv) + = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) + -- See Note [Holes in IfaceCoercion] + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + return $ IfaceReflCo a + 2 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceGReflCo a b c + 3 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceFunCo a b c + 4 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceTyConAppCo a b c + 5 -> do a <- get bh + b <- get bh + return $ IfaceAppCo a b + 6 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceForAllCo a b c + 7 -> do a <- get bh + return $ IfaceCoVarCo a + 8 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceAxiomInstCo a b c + 9 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return $ IfaceUnivCo a b c d + 10-> do a <- get bh + return $ IfaceSymCo a + 11-> do a <- get bh + b <- get bh + return $ IfaceTransCo a b + 12-> do a <- get bh + b <- get bh + return $ IfaceNthCo a b + 13-> do a <- get bh + b <- get bh + return $ IfaceLRCo a b + 14-> do a <- get bh + b <- get bh + return $ IfaceInstCo a b + 15-> do a <- get bh + return $ IfaceKindCo a + 16-> do a <- get bh + return $ IfaceSubCo a + 17-> do a <- get bh + b <- get bh + return $ IfaceAxiomRuleCo a b + _ -> panic ("get IfaceCoercion " ++ show tag) + +instance Binary IfaceUnivCoProv where + put_ bh IfaceUnsafeCoerceProv = putByte bh 1 + put_ bh (IfacePhantomProv a) = do + putByte bh 2 + put_ bh a + put_ bh (IfaceProofIrrelProv a) = do + putByte bh 3 + put_ bh a + put_ bh (IfacePluginProv a) = do + putByte bh 4 + put_ bh a + + get bh = do + tag <- getByte bh + case tag of + 1 -> return $ IfaceUnsafeCoerceProv + 2 -> do a <- get bh + return $ IfacePhantomProv a + 3 -> do a <- get bh + return $ IfaceProofIrrelProv a + 4 -> do a <- get bh + return $ IfacePluginProv a + _ -> panic ("get IfaceUnivCoProv " ++ show tag) + + +instance Binary (DefMethSpec IfaceType) where + put_ bh VanillaDM = putByte bh 0 + put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t + get bh = do + h <- getByte bh + case h of + 0 -> return VanillaDM + _ -> do { t <- get bh; return (GenericDM t) } + +instance NFData IfaceType where + rnf = \case + IfaceFreeTyVar f1 -> f1 `seq` () + IfaceTyVar f1 -> rnf f1 + IfaceLitTy f1 -> rnf f1 + IfaceAppTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceFunTy f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceForAllTy f1 f2 -> f1 `seq` rnf f2 + IfaceTyConApp f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCastTy f1 f2 -> rnf f1 `seq` rnf f2 + IfaceCoercionTy f1 -> rnf f1 + IfaceTupleTy f1 f2 f3 -> f1 `seq` f2 `seq` rnf f3 + +instance NFData IfaceTyLit where + rnf = \case + IfaceNumTyLit f1 -> rnf f1 + IfaceStrTyLit f1 -> rnf f1 + +instance NFData IfaceCoercion where + rnf = \case + IfaceReflCo f1 -> rnf f1 + IfaceGReflCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceFunCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3 + IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceCoVarCo f1 -> rnf f1 + IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 + IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceUnivCo f1 f2 f3 f4 -> rnf f1 `seq` f2 `seq` rnf f3 `seq` rnf f4 + IfaceSymCo f1 -> rnf f1 + IfaceTransCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceNthCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceLRCo f1 f2 -> f1 `seq` rnf f2 + IfaceInstCo f1 f2 -> rnf f1 `seq` rnf f2 + IfaceKindCo f1 -> rnf f1 + IfaceSubCo f1 -> rnf f1 + IfaceFreeCoVar f1 -> f1 `seq` () + IfaceHoleCo f1 -> f1 `seq` () + +instance NFData IfaceUnivCoProv where + rnf x = seq x () + +instance NFData IfaceMCoercion where + rnf x = seq x () + +instance NFData IfaceOneShot where + rnf x = seq x () + +instance NFData IfaceTyConSort where + rnf = \case + IfaceNormalTyCon -> () + IfaceTupleTyCon arity sort -> rnf arity `seq` sort `seq` () + IfaceSumTyCon arity -> rnf arity + IfaceEqualityTyCon -> () + +instance NFData IfaceTyConInfo where + rnf (IfaceTyConInfo f s) = f `seq` rnf s + +instance NFData IfaceTyCon where + rnf (IfaceTyCon nm info) = rnf nm `seq` rnf info + +instance NFData IfaceBndr where + rnf = \case + IfaceIdBndr id_bndr -> rnf id_bndr + IfaceTvBndr tv_bndr -> rnf tv_bndr + +instance NFData IfaceAppArgs where + rnf = \case + IA_Nil -> () + IA_Arg f1 f2 f3 -> rnf f1 `seq` f2 `seq` rnf f3 diff --git a/compiler/GHC/Iface/Type.hs-boot b/compiler/GHC/Iface/Type.hs-boot new file mode 100644 index 0000000000..30a0033c86 --- /dev/null +++ b/compiler/GHC/Iface/Type.hs-boot @@ -0,0 +1,16 @@ +module GHC.Iface.Type + ( IfaceType, IfaceTyCon, IfaceForAllBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs + ) +where + +import Var (VarBndr, ArgFlag) + +data IfaceAppArgs + +data IfaceType +data IfaceTyCon +data IfaceTyLit +data IfaceCoercion +data IfaceBndr +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag diff --git a/compiler/GHC/Iface/Utils.hs b/compiler/GHC/Iface/Utils.hs new file mode 100644 index 0000000000..d410a2c461 --- /dev/null +++ b/compiler/GHC/Iface/Utils.hs @@ -0,0 +1,2078 @@ +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP, NondecreasingIndentation #-} +{-# LANGUAGE MultiWayIf #-} + +-- | Module for constructing @ModIface@ values (interface files), +-- writing them to disk and comparing two versions to see if +-- recompilation is required. +module GHC.Iface.Utils ( + mkPartialIface, + mkFullIface, + + mkIfaceTc, + + writeIfaceFile, -- Write the interface file + + checkOldIface, -- See if recompilation is required, by + -- comparing version information + RecompileRequired(..), recompileRequired, + mkIfaceExports, + + coAxiomToIfaceDecl, + tyThingToIfaceDecl -- Converting things to their Iface equivalents + ) where + +{- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- + +A complete description of how recompilation checking works can be +found in the wiki commentary: + + https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance + +Please read the above page for a top-down description of how this all +works. Notes below cover specific issues related to the implementation. + +Basic idea: + + * In the mi_usages information in an interface, we record the + fingerprint of each free variable of the module + + * In mkIface, we compute the fingerprint of each exported thing A.f. + For each external thing that A.f refers to, we include the fingerprint + of the external reference when computing the fingerprint of A.f. So + if anything that A.f depends on changes, then A.f's fingerprint will + change. + Also record any dependent files added with + * addDependentFile + * #include + * -optP-include + + * In checkOldIface we compare the mi_usages for the module with + the actual fingerprint for all each thing recorded in mi_usages +-} + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Iface.Syntax +import BinFingerprint +import GHC.Iface.Load +import GHC.CoreToIface +import FlagChecker + +import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies ) +import Id +import Annotations +import CoreSyn +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import Type +import TcType +import InstEnv +import FamInstEnv +import TcRnMonad +import GHC.Hs +import HscTypes +import Finder +import DynFlags +import VarEnv +import Var +import Name +import Avail +import RdrName +import NameEnv +import NameSet +import Module +import GHC.Iface.Binary +import ErrUtils +import Digraph +import SrcLoc +import Outputable +import BasicTypes hiding ( SuccessFlag(..) ) +import Unique +import Util hiding ( eqListBy ) +import FastString +import Maybes +import Binary +import Fingerprint +import Exception +import UniqSet +import Packages +import ExtractDocs + +import Control.Monad +import Data.Function +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Ord +import Data.IORef +import System.Directory +import System.FilePath +import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..), + pluginRecompile', plugins ) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup + +{- +************************************************************************ +* * +\subsection{Completing an interface} +* * +************************************************************************ +-} + +mkPartialIface :: HscEnv + -> ModDetails + -> ModGuts + -> PartialModIface +mkPartialIface hsc_env mod_details + ModGuts{ mg_module = this_mod + , mg_hsc_src = hsc_src + , mg_usages = usages + , mg_used_th = used_th + , mg_deps = deps + , mg_rdr_env = rdr_env + , mg_fix_env = fix_env + , mg_warns = warns + , mg_hpc_info = hpc_info + , mg_safe_haskell = safe_mode + , mg_trust_pkg = self_trust + , mg_doc_hdr = doc_hdr + , mg_decl_docs = decl_docs + , mg_arg_docs = arg_docs + } + = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust + safe_mode usages doc_hdr decl_docs arg_docs mod_details + +-- | Fully instantiate a interface +-- Adds fingerprints and potentially code generator produced information. +mkFullIface :: HscEnv -> PartialModIface -> IO ModIface +mkFullIface hsc_env partial_iface = do + full_iface <- + {-# SCC "addFingerprints" #-} + addFingerprints hsc_env partial_iface + + -- Debug printing + dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface) + + return full_iface + +-- | Make an interface from the results of typechecking only. Useful +-- for non-optimising compilation, or where we aren't generating any +-- object code at all ('HscNothing'). +mkIfaceTc :: HscEnv + -> SafeHaskellMode -- The safe haskell mode + -> ModDetails -- gotten from mkBootModDetails, probably + -> TcGblEnv -- Usages, deprecations, etc + -> IO ModIface +mkIfaceTc hsc_env safe_mode mod_details + tc_result@TcGblEnv{ tcg_mod = this_mod, + tcg_src = hsc_src, + tcg_imports = imports, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_merged = merged, + tcg_warns = warns, + tcg_hpc = other_hpc_info, + tcg_th_splice_used = tc_splice_used, + tcg_dependent_files = dependent_files + } + = do + let used_names = mkUsedNames tc_result + let pluginModules = + map lpModule (cachedPlugins (hsc_dflags hsc_env)) + deps <- mkDependencies + (thisInstalledUnitId (hsc_dflags hsc_env)) + (map mi_module pluginModules) tc_result + let hpc_info = emptyHpcInfo other_hpc_info + used_th <- readIORef tc_splice_used + dep_files <- (readIORef dependent_files) + -- Do NOT use semantic module here; this_mod in mkUsageInfo + -- is used solely to decide if we should record a dependency + -- or not. When we instantiate a signature, the semantic + -- module is something we want to record dependencies for, + -- but if you pass that in here, we'll decide it's the local + -- module and does not need to be recorded as a dependency. + -- See Note [Identity versus semantic module] + usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names + dep_files merged pluginModules + + let (doc_hdr', doc_map, arg_map) = extractDocs tc_result + + let partial_iface = mkIface_ hsc_env + this_mod hsc_src + used_th deps rdr_env + fix_env warns hpc_info + (imp_trust_own_pkg imports) safe_mode usages + doc_hdr' doc_map arg_map + mod_details + + mkFullIface hsc_env partial_iface + +mkIface_ :: HscEnv -> Module -> HscSource + -> Bool -> Dependencies -> GlobalRdrEnv + -> NameEnv FixItem -> Warnings -> HpcInfo + -> Bool + -> SafeHaskellMode + -> [Usage] + -> Maybe HsDocString + -> DeclDocMap + -> ArgDocMap + -> ModDetails + -> PartialModIface +mkIface_ hsc_env + this_mod hsc_src used_th deps rdr_env fix_env src_warns + hpc_info pkg_trust_req safe_mode usages + doc_hdr decl_docs arg_docs + ModDetails{ md_insts = insts, + md_fam_insts = fam_insts, + md_rules = rules, + md_anns = anns, + md_types = type_env, + md_exports = exports, + md_complete_sigs = complete_sigs } +-- NB: notice that mkIface does not look at the bindings +-- only at the TypeEnv. The previous Tidy phase has +-- put exactly the info into the TypeEnv that we want +-- to expose in the interface + + = do + let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod) + entities = typeEnvElts type_env + decls = [ tyThingToIfaceDecl entity + | entity <- entities, + let name = getName entity, + not (isImplicitTyThing entity), + -- No implicit Ids and class tycons in the interface file + not (isWiredInName name), + -- Nor wired-in things; the compiler knows about them anyhow + nameIsLocalOrFrom semantic_mod name ] + -- Sigh: see Note [Root-main Id] in TcRnDriver + -- NB: ABSOLUTELY need to check against semantic_mod, + -- because all of the names in an hsig p[H=<H>]:H + -- are going to be for <H>, not the former id! + -- See Note [Identity versus semantic module] + + fixities = sortBy (comparing fst) + [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] + -- The order of fixities returned from nameEnvElts is not + -- deterministic, so we sort by OccName to canonicalize it. + -- See Note [Deterministic UniqFM] in UniqDFM for more details. + warns = src_warns + iface_rules = map coreRuleToIfaceRule rules + iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts + iface_fam_insts = map famInstToIfaceFamInst fam_insts + trust_info = setSafeMode safe_mode + annotations = map mkIfaceAnnotation anns + icomplete_sigs = map mkIfaceCompleteSig complete_sigs + + ModIface { + mi_module = this_mod, + -- Need to record this because it depends on the -instantiated-with flag + -- which could change + mi_sig_of = if semantic_mod == this_mod + then Nothing + else Just semantic_mod, + mi_hsc_src = hsc_src, + mi_deps = deps, + mi_usages = usages, + mi_exports = mkIfaceExports exports, + + -- Sort these lexicographically, so that + -- the result is stable across compilations + mi_insts = sortBy cmp_inst iface_insts, + mi_fam_insts = sortBy cmp_fam_inst iface_fam_insts, + mi_rules = sortBy cmp_rule iface_rules, + + mi_fixities = fixities, + mi_warns = warns, + mi_anns = annotations, + mi_globals = maybeGlobalRdrEnv rdr_env, + mi_used_th = used_th, + mi_decls = decls, + mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, + mi_complete_sigs = icomplete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs, + mi_final_exts = () } + where + cmp_rule = comparing ifRuleName + -- Compare these lexicographically by OccName, *not* by unique, + -- because the latter is not stable across compilations: + cmp_inst = comparing (nameOccName . ifDFun) + cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) + + dflags = hsc_dflags hsc_env + + -- We only fill in mi_globals if the module was compiled to byte + -- code. Otherwise, the compiler may not have retained all the + -- top-level bindings and they won't be in the TypeEnv (see + -- Desugar.addExportFlagsAndRules). The mi_globals field is used + -- by GHCi to decide whether the module has its full top-level + -- scope available. (#5534) + maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv + maybeGlobalRdrEnv rdr_env + | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env + | otherwise = Nothing + + ifFamInstTcName = ifFamInstFam + +----------------------------- +writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO () +writeIfaceFile dflags hi_file_path new_iface + = do createDirectoryIfMissing True (takeDirectory hi_file_path) + writeBinIface dflags hi_file_path new_iface + + +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names + +-- This is like a global version of the mi_hash_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get +-- the parent and version info. + +mkHashFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> IO Fingerprint) +mkHashFun hsc_env eps name + | isHoleModule orig_mod + = lookup (mkModule (thisPackage dflags) (moduleName orig_mod)) + | otherwise + = lookup orig_mod + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + occ = nameOccName name + orig_mod = nameModule name + lookup mod = do + MASSERT2( isExternalName name, ppr name ) + iface <- case lookupIfaceByModule hpt pit mod of + Just iface -> return iface + Nothing -> do + -- This can occur when we're writing out ifaces for + -- requirements; we didn't do any /real/ typechecking + -- so there's no guarantee everything is loaded. + -- Kind of a heinous hack. + iface <- initIfaceLoad hsc_env . withException + $ loadInterface (text "lookupVers2") mod ImportBySystem + return iface + return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ)) + +-- --------------------------------------------------------------------------- +-- Compute fingerprints for the interface + +{- +Note [Fingerprinting IfaceDecls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The general idea here is that we first examine the 'IfaceDecl's and determine +the recursive groups of them. We then walk these groups in dependency order, +serializing each contained 'IfaceDecl' to a "Binary" buffer which we then +hash using MD5 to produce a fingerprint for the group. + +However, the serialization that we use is a bit funny: we override the @putName@ +operation with our own which serializes the hash of a 'Name' instead of the +'Name' itself. This ensures that the fingerprint of a decl changes if anything +in its transitive closure changes. This trick is why we must be careful about +traversing in dependency order: we need to ensure that we have hashes for +everything referenced by the decl which we are fingerprinting. + +Moreover, we need to be careful to distinguish between serialization of binding +Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls +field of a IfaceClsInst): only in the non-binding case should we include the +fingerprint; in the binding case we shouldn't since it is merely the name of the +thing that we are currently fingerprinting. +-} + +-- | Add fingerprints for top-level declarations to a 'ModIface'. +-- +-- See Note [Fingerprinting IfaceDecls] +addFingerprints + :: HscEnv + -> PartialModIface + -> IO ModIface +addFingerprints hsc_env iface0 + = do + eps <- hscEPS hsc_env + let + decls = mi_decls iface0 + warn_fn = mkIfaceWarnCache (mi_warns iface0) + fix_fn = mkIfaceFixCache (mi_fixities iface0) + + -- The ABI of a declaration represents everything that is made + -- visible about the declaration that a client can depend on. + -- see IfaceDeclABI below. + declABI :: IfaceDecl -> IfaceDeclABI + -- TODO: I'm not sure if this should be semantic_mod or this_mod. + -- See also Note [Identity versus semantic module] + declABI decl = (this_mod, decl, extras) + where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts + non_orph_fis top_lvl_name_env decl + + -- This is used for looking up the Name of a default method + -- from its OccName. See Note [default method Name] + top_lvl_name_env = + mkOccEnv [ (nameOccName nm, nm) + | IfaceId { ifName = nm } <- decls ] + + -- Dependency edges between declarations in the current module. + -- This is computed by finding the free external names of each + -- declaration, including IfaceDeclExtras (things that a + -- declaration implicitly depends on). + edges :: [ Node Unique IfaceDeclABI ] + edges = [ DigraphNode abi (getUnique (getOccName decl)) out + | decl <- decls + , let abi = declABI decl + , let out = localOccs $ freeNamesDeclABI abi + ] + + name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n + localOccs = + map (getUnique . getParent . getOccName) + -- NB: names always use semantic module, so + -- filtering must be on the semantic module! + -- See Note [Identity versus semantic module] + . filter ((== semantic_mod) . name_module) + . nonDetEltsUniqSet + -- It's OK to use nonDetEltsUFM as localOccs is only + -- used to construct the edges and + -- stronglyConnCompFromEdgedVertices is deterministic + -- even with non-deterministic order of edges as + -- explained in Note [Deterministic SCC] in Digraph. + where getParent :: OccName -> OccName + getParent occ = lookupOccEnv parent_map occ `orElse` occ + + -- maps OccNames to their parents in the current module. + -- e.g. a reference to a constructor must be turned into a reference + -- to the TyCon for the purposes of calculating dependencies. + parent_map :: OccEnv OccName + parent_map = foldl' extend emptyOccEnv decls + where extend env d = + extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ] + where n = getOccName d + + -- Strongly-connected groups of declarations, in dependency order + groups :: [SCC IfaceDeclABI] + groups = stronglyConnCompFromEdgedVerticesUniq edges + + global_hash_fn = mkHashFun hsc_env eps + + -- How to output Names when generating the data to fingerprint. + -- Here we want to output the fingerprint for each top-level + -- Name, whether it comes from the current module or another + -- module. In this way, the fingerprint for a declaration will + -- change if the fingerprint for anything it refers to (transitively) + -- changes. + mk_put_name :: OccEnv (OccName,Fingerprint) + -> BinHandle -> Name -> IO () + mk_put_name local_env bh name + | isWiredInName name = putNameLiterally bh name + -- wired-in names don't have fingerprints + | otherwise + = ASSERT2( isExternalName name, ppr name ) + let hash | nameModule name /= semantic_mod = global_hash_fn name + -- Get it from the REAL interface!! + -- This will trigger when we compile an hsig file + -- and we know a backing impl for it. + -- See Note [Identity versus semantic module] + | semantic_mod /= this_mod + , not (isHoleModule semantic_mod) = global_hash_fn name + | otherwise = return (snd (lookupOccEnv local_env (getOccName name) + `orElse` pprPanic "urk! lookup local fingerprint" + (ppr name $$ ppr local_env))) + -- This panic indicates that we got the dependency + -- analysis wrong, because we needed a fingerprint for + -- an entity that wasn't in the environment. To debug + -- it, turn the panic into a trace, uncomment the + -- pprTraces below, run the compile again, and inspect + -- the output and the generated .hi file with + -- --show-iface. + in hash >>= put_ bh + + -- take a strongly-connected group of declarations and compute + -- its fingerprint. + + fingerprint_group :: (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + -> SCC IfaceDeclABI + -> IO (OccEnv (OccName,Fingerprint), + [(Fingerprint,IfaceDecl)]) + + fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) + = do let hash_fn = mk_put_name local_env + decl = abiDecl abi + --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do + hash <- computeFingerprint hash_fn abi + env' <- extend_hash_env local_env (hash,decl) + return (env', (hash,decl) : decls_w_hashes) + + fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) + = do let decls = map abiDecl abis + local_env1 <- foldM extend_hash_env local_env + (zip (repeat fingerprint0) decls) + let hash_fn = mk_put_name local_env1 + -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do + let stable_abis = sortBy cmp_abiNames abis + -- put the cycle in a canonical order + hash <- computeFingerprint hash_fn stable_abis + let pairs = zip (repeat hash) decls + local_env2 <- foldM extend_hash_env local_env pairs + return (local_env2, pairs ++ decls_w_hashes) + + -- we have fingerprinted the whole declaration, but we now need + -- to assign fingerprints to all the OccNames that it binds, to + -- use when referencing those OccNames in later declarations. + -- + extend_hash_env :: OccEnv (OccName,Fingerprint) + -> (Fingerprint,IfaceDecl) + -> IO (OccEnv (OccName,Fingerprint)) + extend_hash_env env0 (hash,d) = do + return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 + (ifaceDeclFingerprints hash d)) + + -- + (local_env, decls_w_hashes) <- + foldM fingerprint_group (emptyOccEnv, []) groups + + -- when calculating fingerprints, we always need to use canonical + -- ordering for lists of things. In particular, the mi_deps has various + -- lists of modules and suchlike, so put these all in canonical order: + let sorted_deps = sortDependencies (mi_deps iface0) + + -- The export hash of a module depends on the orphan hashes of the + -- orphan modules below us in the dependency tree. This is the way + -- that changes in orphans get propagated all the way up the + -- dependency tree. + -- + -- Note [A bad dep_orphs optimization] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- In a previous version of this code, we filtered out orphan modules which + -- were not from the home package, justifying it by saying that "we'd + -- pick up the ABI hashes of the external module instead". This is wrong. + -- Suppose that we have: + -- + -- module External where + -- instance Show (a -> b) + -- + -- module Home1 where + -- import External + -- + -- module Home2 where + -- import Home1 + -- + -- The export hash of Home1 needs to reflect the orphan instances of + -- External. It's true that Home1 will get rebuilt if the orphans + -- of External, but we also need to make sure Home2 gets rebuilt + -- as well. See #12733 for more details. + let orph_mods + = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot] + $ dep_orphs sorted_deps + dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods + + -- Note [Do not update EPS with your own hi-boot] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- (See also #10182). When your hs-boot file includes an orphan + -- instance declaration, you may find that the dep_orphs of a module you + -- import contains reference to yourself. DO NOT actually load this module + -- or add it to the orphan hashes: you're going to provide the orphan + -- instances yourself, no need to consult hs-boot; if you do load the + -- interface into EPS, you will see a duplicate orphan instance. + + orphan_hash <- computeFingerprint (mk_put_name local_env) + (map ifDFun orph_insts, orph_rules, orph_fis) + + -- the export list hash doesn't depend on the fingerprints of + -- the Names it mentions, only the Names themselves, hence putNameLiterally. + export_hash <- computeFingerprint putNameLiterally + (mi_exports iface0, + orphan_hash, + dep_orphan_hashes, + dep_pkgs (mi_deps iface0), + -- See Note [Export hash depends on non-orphan family instances] + dep_finsts (mi_deps iface0), + -- dep_pkgs: see "Package Version Changes" on + -- wiki/commentary/compiler/recompilation-avoidance + mi_trust iface0) + -- Make sure change of Safe Haskell mode causes recomp. + + -- Note [Export hash depends on non-orphan family instances] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- + -- Suppose we have: + -- + -- module A where + -- type instance F Int = Bool + -- + -- module B where + -- import A + -- + -- module C where + -- import B + -- + -- The family instance consistency check for C depends on the dep_finsts of + -- B. If we rename module A to A2, when the dep_finsts of B changes, we need + -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of + -- the exports of B, because C always considers them when checking + -- consistency. + -- + -- A full discussion is in #12723. + -- + -- We do NOT need to hash dep_orphs, because this is implied by + -- dep_orphan_hashes, and we do not need to hash ordinary class instances, + -- because there is no eager consistency check as there is with type families + -- (also we didn't store it anywhere!) + -- + + -- put the declarations in a canonical order, sorted by OccName + let sorted_decls = Map.elems $ Map.fromList $ + [(getOccName d, e) | e@(_, d) <- decls_w_hashes] + + -- the flag hash depends on: + -- - (some of) dflags + -- it returns two hashes, one that shouldn't change + -- the abi hash and one that should + flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally + + opt_hash <- fingerprintOptFlags dflags putNameLiterally + + hpc_hash <- fingerprintHpcFlags dflags putNameLiterally + + plugin_hash <- fingerprintPlugins hsc_env + + -- the ABI hash depends on: + -- - decls + -- - export list + -- - orphans + -- - deprecations + -- - flag abi hash + mod_hash <- computeFingerprint putNameLiterally + (map fst sorted_decls, + export_hash, -- includes orphan_hash + mi_warns iface0) + + -- The interface hash depends on: + -- - the ABI hash, plus + -- - the module level annotations, + -- - usages + -- - deps (home and external packages, dependent files) + -- - hpc + iface_hash <- computeFingerprint putNameLiterally + (mod_hash, + ann_fn (mkVarOcc "module"), -- See mkIfaceAnnCache + mi_usages iface0, + sorted_deps, + mi_hpc iface0) + + let + final_iface_exts = ModIfaceBackend + { mi_iface_hash = iface_hash + , mi_mod_hash = mod_hash + , mi_flag_hash = flag_hash + , mi_opt_hash = opt_hash + , mi_hpc_hash = hpc_hash + , mi_plugin_hash = plugin_hash + , mi_orphan = not ( all ifRuleAuto orph_rules + -- See Note [Orphans and auto-generated rules] + && null orph_insts + && null orph_fis) + , mi_finsts = not (null (mi_fam_insts iface0)) + , mi_exp_hash = export_hash + , mi_orphan_hash = orphan_hash + , mi_warn_fn = warn_fn + , mi_fix_fn = fix_fn + , mi_hash_fn = lookupOccEnv local_env + } + final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts } + -- + return final_iface + + where + this_mod = mi_module iface0 + semantic_mod = mi_semantic_module iface0 + dflags = hsc_dflags hsc_env + (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph (mi_insts iface0) + (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph (mi_rules iface0) + (non_orph_fis, orph_fis) = mkOrphMap ifFamInstOrph (mi_fam_insts iface0) + ann_fn = mkIfaceAnnCache (mi_anns iface0) + +-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules +-- (in particular, the orphan modules which are transitively imported by the +-- current module). +-- +-- Q: Why do we need the hash at all, doesn't the list of transitively +-- imported orphan modules suffice? +-- +-- A: If one of our transitive imports adds a new orphan instance, our +-- export hash must change so that modules which import us rebuild. If we just +-- hashed the [Module], the hash would not change even when a new instance was +-- added to a module that already had an orphan instance. +-- +-- Q: Why don't we just hash the orphan hashes of our direct dependencies? +-- Why the full transitive closure? +-- +-- A: Suppose we have these modules: +-- +-- module A where +-- instance Show (a -> b) where +-- module B where +-- import A -- ** +-- module C where +-- import A +-- import B +-- +-- Whether or not we add or remove the import to A in B affects the +-- orphan hash of B. But it shouldn't really affect the orphan hash +-- of C. If we hashed only direct dependencies, there would be no +-- way to tell that the net effect was a wash, and we'd be forced +-- to recompile C and everything else. +getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint] +getOrphanHashes hsc_env mods = do + eps <- hscEPS hsc_env + let + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + get_orph_hash mod = + case lookupIfaceByModule hpt pit mod of + Just iface -> return (mi_orphan_hash (mi_final_exts iface)) + Nothing -> do -- similar to 'mkHashFun' + iface <- initIfaceLoad hsc_env . withException + $ loadInterface (text "getOrphanHashes") mod ImportBySystem + return (mi_orphan_hash (mi_final_exts iface)) + + -- + mapM get_orph_hash mods + + +sortDependencies :: Dependencies -> Dependencies +sortDependencies d + = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), + dep_pkgs = sortBy (compare `on` fst) (dep_pkgs d), + dep_orphs = sortBy stableModuleCmp (dep_orphs d), + dep_finsts = sortBy stableModuleCmp (dep_finsts d), + dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) } + +-- | Creates cached lookup for the 'mi_anns' field of ModIface +-- Hackily, we use "module" as the OccName for any module-level annotations +mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload] +mkIfaceAnnCache anns + = \n -> lookupOccEnv env n `orElse` [] + where + pair (IfaceAnnotation target value) = + (case target of + NamedTarget occn -> occn + ModuleTarget _ -> mkVarOcc "module" + , [value]) + -- flipping (++), so the first argument is always short + env = mkOccEnv_C (flip (++)) (map pair anns) + +{- +************************************************************************ +* * + The ABI of an IfaceDecl +* * +************************************************************************ + +Note [The ABI of an IfaceDecl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ABI of a declaration consists of: + + (a) the full name of the identifier (inc. module and package, + because these are used to construct the symbol name by which + the identifier is known externally). + + (b) the declaration itself, as exposed to clients. That is, the + definition of an Id is included in the fingerprint only if + it is made available as an unfolding in the interface. + + (c) the fixity of the identifier (if it exists) + (d) for Ids: rules + (e) for classes: instances, fixity & rules for methods + (f) for datatypes: instances, fixity & rules for constrs + +Items (c)-(f) are not stored in the IfaceDecl, but instead appear +elsewhere in the interface file. But they are *fingerprinted* with +the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras, +and fingerprinting that as part of the declaration. +-} + +type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras) + +data IfaceDeclExtras + = IfaceIdExtras IfaceIdExtras + + | IfaceDataExtras + (Maybe Fixity) -- Fixity of the tycon itself (if it exists) + [IfaceInstABI] -- Local class and family instances of this tycon + -- See Note [Orphans] in InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each constructor: fixity, RULES and annotations + + | IfaceClassExtras + (Maybe Fixity) -- Fixity of the class itself (if it exists) + [IfaceInstABI] -- Local instances of this class *or* + -- of its associated data types + -- See Note [Orphans] in InstEnv + [AnnPayload] -- Annotations of the type itself + [IfaceIdExtras] -- For each class method: fixity, RULES and annotations + [IfExtName] -- Default methods. If a module + -- mentions a class, then it can + -- instantiate the class and thereby + -- use the default methods, so we must + -- include these in the fingerprint of + -- a class. + + | IfaceSynonymExtras (Maybe Fixity) [AnnPayload] + + | IfaceFamilyExtras (Maybe Fixity) [IfaceInstABI] [AnnPayload] + + | IfaceOtherDeclExtras + +data IfaceIdExtras + = IdExtras + (Maybe Fixity) -- Fixity of the Id (if it exists) + [IfaceRule] -- Rules for the Id + [AnnPayload] -- Annotations for the Id + +-- When hashing a class or family instance, we hash only the +-- DFunId or CoAxiom, because that depends on all the +-- information about the instance. +-- +type IfaceInstABI = IfExtName -- Name of DFunId or CoAxiom that is evidence for the instance + +abiDecl :: IfaceDeclABI -> IfaceDecl +abiDecl (_, decl, _) = decl + +cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering +cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare` + getOccName (abiDecl abi2) + +freeNamesDeclABI :: IfaceDeclABI -> NameSet +freeNamesDeclABI (_mod, decl, extras) = + freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras + +freeNamesDeclExtras :: IfaceDeclExtras -> NameSet +freeNamesDeclExtras (IfaceIdExtras id_extras) + = freeNamesIdExtras id_extras +freeNamesDeclExtras (IfaceDataExtras _ insts _ subs) + = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs) +freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms) + = unionNameSets $ + mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs +freeNamesDeclExtras (IfaceSynonymExtras _ _) + = emptyNameSet +freeNamesDeclExtras (IfaceFamilyExtras _ insts _) + = mkNameSet insts +freeNamesDeclExtras IfaceOtherDeclExtras + = emptyNameSet + +freeNamesIdExtras :: IfaceIdExtras -> NameSet +freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules) + +instance Outputable IfaceDeclExtras where + ppr IfaceOtherDeclExtras = Outputable.empty + ppr (IfaceIdExtras extras) = ppr_id_extras extras + ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns] + ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns] + ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff] + ppr (IfaceClassExtras fix insts anns stuff defms) = + vcat [ppr fix, ppr_insts insts, ppr anns, + ppr_id_extras_s stuff, ppr defms] + +ppr_insts :: [IfaceInstABI] -> SDoc +ppr_insts _ = text "<insts>" + +ppr_id_extras_s :: [IfaceIdExtras] -> SDoc +ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff) + +ppr_id_extras :: IfaceIdExtras -> SDoc +ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns) + +-- This instance is used only to compute fingerprints +instance Binary IfaceDeclExtras where + get _bh = panic "no get for IfaceDeclExtras" + put_ bh (IfaceIdExtras extras) = do + putByte bh 1; put_ bh extras + put_ bh (IfaceDataExtras fix insts anns cons) = do + putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons + put_ bh (IfaceClassExtras fix insts anns methods defms) = do + putByte bh 3 + put_ bh fix + put_ bh insts + put_ bh anns + put_ bh methods + put_ bh defms + put_ bh (IfaceSynonymExtras fix anns) = do + putByte bh 4; put_ bh fix; put_ bh anns + put_ bh (IfaceFamilyExtras fix finsts anns) = do + putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns + put_ bh IfaceOtherDeclExtras = putByte bh 6 + +instance Binary IfaceIdExtras where + get _bh = panic "no get for IfaceIdExtras" + put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } + +declExtras :: (OccName -> Maybe Fixity) + -> (OccName -> [AnnPayload]) + -> OccEnv [IfaceRule] + -> OccEnv [IfaceClsInst] + -> OccEnv [IfaceFamInst] + -> OccEnv IfExtName -- lookup default method names + -> IfaceDecl + -> IfaceDeclExtras + +declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl + = case decl of + IfaceId{} -> IfaceIdExtras (id_extras n) + IfaceData{ifCons=cons} -> + IfaceDataExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n) ++ + map ifDFun (lookupOccEnvL inst_env n)) + (ann_fn n) + (map (id_extras . occName . ifConName) (visibleIfConDecls cons)) + IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} -> + IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms + where + insts = (map ifDFun $ (concatMap at_extras ats) + ++ lookupOccEnvL inst_env n) + -- Include instances of the associated types + -- as well as instances of the class (#5147) + meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs] + -- Names of all the default methods (see Note [default method Name]) + defms = [ dmName + | IfaceClassOp bndr _ (Just _) <- sigs + , let dmOcc = mkDefaultMethodOcc (nameOccName bndr) + , Just dmName <- [lookupOccEnv dm_env dmOcc] ] + IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n) + (ann_fn n) + IfaceFamily{} -> IfaceFamilyExtras (fix_fn n) + (map ifFamInstAxiom (lookupOccEnvL fi_env n)) + (ann_fn n) + _other -> IfaceOtherDeclExtras + where + n = getOccName decl + id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ) + at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl) + + +{- Note [default method Name] (see also #15970) + +The Names for the default methods aren't available in Iface syntax. + +* We originally start with a DefMethInfo from the class, contain a + Name for the default method + +* We turn that into Iface syntax as a DefMethSpec which lacks a Name + entirely. Why? Because the Name can be derived from the method name + (in GHC.IfaceToCore), so doesn't need to be serialised into the interface + file. + +But now we have to get the Name back, because the class declaration's +fingerprint needs to depend on it (this was the bug in #15970). This +is done in a slightly convoluted way: + +* Then, in addFingerprints we build a map that maps OccNames to Names + +* We pass that map to declExtras which laboriously looks up in the map + (using the derived occurrence name) to recover the Name we have just + thrown away. +-} + +lookupOccEnvL :: OccEnv [v] -> OccName -> [v] +lookupOccEnvL env k = lookupOccEnv env k `orElse` [] + +{- +-- for testing: use the md5sum command to generate fingerprints and +-- compare the results against our built-in version. + fp' <- oldMD5 dflags bh + if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp') + else return fp + +oldMD5 dflags bh = do + tmp <- newTempName dflags CurrentModule "bin" + writeBinMem bh tmp + tmp2 <- newTempName dflags CurrentModule "md5" + let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2 + r <- system cmd + case r of + ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r) + ExitSuccess -> do + hash_str <- readFile tmp2 + return $! readHexFingerprint hash_str +-} + +---------------------- +-- mkOrphMap partitions instance decls or rules into +-- (a) an OccEnv for ones that are not orphans, +-- mapping the local OccName to a list of its decls +-- (b) a list of orphan decls +mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl + -> [decl] -- Sorted into canonical order + -> (OccEnv [decl], -- Non-orphan decls associated with their key; + -- each sublist in canonical order + [decl]) -- Orphan decls; in canonical order +mkOrphMap get_key decls + = foldl' go (emptyOccEnv, []) decls + where + go (non_orphs, orphs) d + | NotOrphan occ <- get_key d + = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs) + | otherwise = (non_orphs, d:orphs) + +{- +************************************************************************ +* * + COMPLETE Pragmas +* * +************************************************************************ +-} + +mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch +mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc + + +{- +************************************************************************ +* * + Keeping track of what we've slurped, and fingerprints +* * +************************************************************************ +-} + + +mkIfaceAnnotation :: Annotation -> IfaceAnnotation +mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload }) + = IfaceAnnotation { + ifAnnotatedTarget = fmap nameOccName target, + ifAnnotatedValue = payload + } + +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical +mkIfaceExports exports + = sortBy stableAvailCmp (map sort_subs exports) + where + sort_subs :: AvailInfo -> AvailInfo + sort_subs (Avail n) = Avail n + sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs) + sort_subs (AvailTC n (m:ms) fs) + | n==m = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs) + | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs) + -- Maintain the AvailTC Invariant + + sort_flds = sortBy (stableNameCmp `on` flSelector) + +{- +Note [Original module] +~~~~~~~~~~~~~~~~~~~~~ +Consider this: + module X where { data family T } + module Y( T(..) ) where { import X; data instance T Int = MkT Int } +The exported Avail from Y will look like + X.T{X.T, Y.MkT} +That is, in Y, + - only MkT is brought into scope by the data instance; + - but the parent (used for grouping and naming in T(..) exports) is X.T + - and in this case we export X.T too + +In the result of mkIfaceExports, the names are grouped by defining module, +so we may need to split up a single Avail into multiple ones. + +Note [Internal used_names] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the used_names are External Names, but we can have Internal +Names too: see Note [Binders in Template Haskell] in Convert, and +#5362 for an example. Such Names are always + - Such Names are always for locally-defined things, for which we + don't gather usage info, so we can just ignore them in ent_map + - They are always System Names, hence the assert, just as a double check. + + +************************************************************************ +* * + Load the old interface file for this module (unless + we have it already), and check whether it is up to date +* * +************************************************************************ +-} + +data RecompileRequired + = UpToDate + -- ^ everything is up to date, recompilation is not required + | MustCompile + -- ^ The .hs file has been touched, or the .o/.hi file does not exist + | RecompBecause String + -- ^ The .o/.hi files are up to date, but something else has changed + -- to force recompilation; the String says what (one-line summary) + deriving Eq + +instance Semigroup RecompileRequired where + UpToDate <> r = r + mc <> _ = mc + +instance Monoid RecompileRequired where + mempty = UpToDate + +recompileRequired :: RecompileRequired -> Bool +recompileRequired UpToDate = False +recompileRequired _ = True + + + +-- | Top level function to check if the version of an old interface file +-- is equivalent to the current source file the user asked us to compile. +-- If the same, we can avoid recompilation. We return a tuple where the +-- first element is a bool saying if we should recompile the object file +-- and the second is maybe the interface file, where Nothing means to +-- rebuild the interface file and not use the existing one. +checkOldIface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface -- Old interface from compilation manager, if any + -> IO (RecompileRequired, Maybe ModIface) + +checkOldIface hsc_env mod_summary source_modified maybe_iface + = do let dflags = hsc_dflags hsc_env + showPass dflags $ + "Checking old interface for " ++ + (showPpr dflags $ ms_mod mod_summary) ++ + " (use -ddump-hi-diffs for more details)" + initIfaceCheck (text "checkOldIface") hsc_env $ + check_old_iface hsc_env mod_summary source_modified maybe_iface + +check_old_iface + :: HscEnv + -> ModSummary + -> SourceModified + -> Maybe ModIface + -> IfG (RecompileRequired, Maybe ModIface) + +check_old_iface hsc_env mod_summary src_modified maybe_iface + = let dflags = hsc_dflags hsc_env + getIface = + case maybe_iface of + Just _ -> do + traceIf (text "We already have the old interface for" <+> + ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> loadIface + + loadIface = do + let iface_path = msHiFilePath mod_summary + read_result <- readIface (ms_mod mod_summary) iface_path + case read_result of + Failed err -> do + traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err) + traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err) + return Nothing + Succeeded iface -> do + traceIf (text "Read the interface file" <+> text iface_path) + return $ Just iface + + src_changed + | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True + | SourceModified <- src_modified = True + | otherwise = False + in do + when src_changed $ + traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off") + + case src_changed of + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + True | not (isObjectTarget $ hscTarget dflags) -> + return (MustCompile, maybe_iface) + + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + True -> do + maybe_iface' <- getIface + return (MustCompile, maybe_iface') + + False -> do + maybe_iface' <- getIface + case maybe_iface' of + -- We can't retrieve the iface + Nothing -> return (MustCompile, Nothing) + + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + Just iface -> checkVersions hsc_env mod_summary iface + +-- | Check if a module is still the same 'version'. +-- +-- This function is called in the recompilation checker after we have +-- determined that the module M being checked hasn't had any changes +-- to its source file since we last compiled M. So at this point in general +-- two things may have changed that mean we should recompile M: +-- * The interface export by a dependency of M has changed. +-- * The compiler flags specified this time for M have changed +-- in a manner that is significant for recompilation. +-- We return not just if we should recompile the object file but also +-- if we should rebuild the interface file. +checkVersions :: HscEnv + -> ModSummary + -> ModIface -- Old interface + -> IfG (RecompileRequired, Maybe ModIface) +checkVersions hsc_env mod_summary iface + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) + + -- readIface will have verified that the InstalledUnitId matches, + -- but we ALSO must make sure the instantiation matches up. See + -- test case bkpcabal04! + ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env) + then return (RecompBecause "-this-unit-id changed", Nothing) else do { + ; recomp <- checkFlagHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkOptimHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkHpcHash hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkMergedSignatures mod_summary iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkHsig mod_summary iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkHie mod_summary + ; if recompileRequired recomp then return (recomp, Nothing) else do { + ; recomp <- checkDependencies hsc_env mod_summary iface + ; if recompileRequired recomp then return (recomp, Just iface) else do { + ; recomp <- checkPlugins hsc_env iface + ; if recompileRequired recomp then return (recomp, Nothing) else do { + + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + -- + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant + ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; return (recomp, Just iface) + }}}}}}}}}} + where + this_pkg = thisPackage (hsc_dflags hsc_env) + -- This is a bit of a hack really + mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) + mod_deps = mkModDeps (dep_mods (mi_deps iface)) + +-- | Check if any plugins are requesting recompilation +checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired +checkPlugins hsc iface = liftIO $ do + new_fingerprint <- fingerprintPlugins hsc + let old_fingerprint = mi_plugin_hash (mi_final_exts iface) + pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc)) + return $ + pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr + +fingerprintPlugins :: HscEnv -> IO Fingerprint +fingerprintPlugins hsc_env = do + fingerprintPlugins' $ plugins (hsc_dflags hsc_env) + +fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint +fingerprintPlugins' plugins = do + res <- mconcat <$> mapM pluginRecompile' plugins + return $ case res of + NoForceRecompile -> fingerprintString "NoForceRecompile" + ForceRecompile -> fingerprintString "ForceRecompile" + -- is the chance of collision worth worrying about? + -- An alternative is to fingerprintFingerprints [fingerprintString + -- "maybeRecompile", fp] + (MaybeRecompile fp) -> fp + + +pluginRecompileToRecompileRequired + :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired +pluginRecompileToRecompileRequired old_fp new_fp pr + | old_fp == new_fp = + case pr of + NoForceRecompile -> UpToDate + + -- we already checked the fingerprint above so a mismatch is not possible + -- here, remember that: `fingerprint (MaybeRecomp x) == x`. + MaybeRecompile _ -> UpToDate + + -- when we have an impure plugin in the stack we have to unconditionally + -- recompile since it might integrate all sorts of crazy IO results into + -- its compilation output. + ForceRecompile -> RecompBecause "Impure plugin forced recompilation" + + | old_fp `elem` magic_fingerprints || + new_fp `elem` magic_fingerprints + -- The fingerprints do not match either the old or new one is a magic + -- fingerprint. This happens when non-pure plugins are added for the first + -- time or when we go from one recompilation strategy to another: (force -> + -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.) + -- + -- For example when we go from from ForceRecomp to NoForceRecomp + -- recompilation is triggered since the old impure plugins could have + -- changed the build output which is now back to normal. + = RecompBecause "Plugins changed" + + | otherwise = + let reason = "Plugin fingerprint changed" in + case pr of + -- even though a plugin is forcing recompilation the fingerprint changed + -- which would cause recompilation anyways so we report the fingerprint + -- change instead. + ForceRecompile -> RecompBecause reason + + _ -> RecompBecause reason + + where + magic_fingerprints = + [ fingerprintString "NoForceRecompile" + , fingerprintString "ForceRecompile" + ] + + +-- | Check if an hsig file needs recompilation because its +-- implementing module has changed. +checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired +checkHsig mod_summary iface = do + dflags <- getDynFlags + let outer_mod = ms_mod mod_summary + inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod) + MASSERT( moduleUnitId outer_mod == thisPackage dflags ) + case inner_mod == mi_semantic_module iface of + True -> up_to_date (text "implementing module unchanged") + False -> return (RecompBecause "implementing module changed") + +-- | Check if @.hie@ file is out of date or missing. +checkHie :: ModSummary -> IfG RecompileRequired +checkHie mod_summary = do + dflags <- getDynFlags + let hie_date_opt = ms_hie_date mod_summary + hs_date = ms_hs_date mod_summary + pure $ case gopt Opt_WriteHie dflags of + False -> UpToDate + True -> case hie_date_opt of + Nothing -> RecompBecause "HIE file is missing" + Just hie_date + | hie_date < hs_date + -> RecompBecause "HIE file is out of date" + | otherwise + -> UpToDate + +-- | Check the flags haven't changed +checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkFlagHash hsc_env iface = do + let old_hash = mi_flag_hash (mi_final_exts iface) + new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env) + (mi_module iface) + putNameLiterally + case old_hash == new_hash of + True -> up_to_date (text "Module flags unchanged") + False -> out_of_date_hash "flags changed" + (text " Module flags have changed") + old_hash new_hash + +-- | Check the optimisation flags haven't changed +checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkOptimHash hsc_env iface = do + let old_hash = mi_opt_hash (mi_final_exts iface) + new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date (text "Optimisation flags unchanged") + | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env) + -> up_to_date (text "Optimisation flags changed; ignoring") + | otherwise + -> out_of_date_hash "Optimisation flags changed" + (text " Optimisation flags have changed") + old_hash new_hash + +-- | Check the HPC flags haven't changed +checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired +checkHpcHash hsc_env iface = do + let old_hash = mi_hpc_hash (mi_final_exts iface) + new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env) + putNameLiterally + if | old_hash == new_hash + -> up_to_date (text "HPC flags unchanged") + | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env) + -> up_to_date (text "HPC flags changed; ignoring") + | otherwise + -> out_of_date_hash "HPC flags changed" + (text " HPC flags have changed") + old_hash new_hash + +-- Check that the set of signatures we are merging in match. +-- If the -unit-id flags change, this can change too. +checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired +checkMergedSignatures mod_summary iface = do + dflags <- getDynFlags + let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ] + new_merged = case Map.lookup (ms_mod_name mod_summary) + (requirementContext (pkgState dflags)) of + Nothing -> [] + Just r -> sort $ map (indefModuleToModule dflags) r + if old_merged == new_merged + then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged) + else return (RecompBecause "signatures to merge in changed") + +-- If the direct imports of this module are resolved to targets that +-- are not among the dependencies of the previous interface file, +-- then we definitely need to recompile. This catches cases like +-- - an exposed package has been upgraded +-- - we are compiling with different package flags +-- - a home module that was shadowing a package module has been removed +-- - a new home module has been added that shadows a package module +-- See bug #1372. +-- +-- In addition, we also check if the union of dependencies of the imported +-- modules has any difference to the previous set of dependencies. We would need +-- to recompile in that case also since the `mi_deps` field of ModIface needs +-- to be updated to match that information. This is one of the invariants +-- of interface files (see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#interface-file-invariants). +-- See bug #16511. +-- +-- Returns (RecompBecause <textual reason>) if recompilation is required. +checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired +checkDependencies hsc_env summary iface + = do + checkList $ + [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary)) + , do + (recomp, mnames_seen) <- runUntilRecompRequired $ map + checkForNewHomeDependency + (ms_home_imps summary) + case recomp of + UpToDate -> do + let + seen_home_deps = Set.unions $ map Set.fromList mnames_seen + checkIfAllOldHomeDependenciesAreSeen seen_home_deps + _ -> return recomp] + where + prev_dep_mods = dep_mods (mi_deps iface) + prev_dep_plgn = dep_plgins (mi_deps iface) + prev_dep_pkgs = dep_pkgs (mi_deps iface) + + this_pkg = thisPackage (hsc_dflags hsc_env) + + dep_missing (mb_pkg, L _ mod) = do + find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg) + let reason = moduleNameString mod ++ " changed" + case find_res of + Found _ mod + | pkg == this_pkg + -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " not among previous dependencies" + return (RecompBecause reason) + else + return UpToDate + | otherwise + -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs) + then do traceHiDiffs $ + text "imported module " <> quotes (ppr mod) <> + text " is from package " <> quotes (ppr pkg) <> + text ", which is not among previous dependencies" + return (RecompBecause reason) + else + return UpToDate + where pkg = moduleUnitId mod + _otherwise -> return (RecompBecause reason) + + old_deps = Set.fromList $ map fst $ filter (not . snd) prev_dep_mods + isOldHomeDeps = flip Set.member old_deps + checkForNewHomeDependency (L _ mname) = do + let + mod = mkModule this_pkg mname + str_mname = moduleNameString mname + reason = str_mname ++ " changed" + -- We only want to look at home modules to check if any new home dependency + -- pops in and thus here, skip modules that are not home. Checking + -- membership in old home dependencies suffice because the `dep_missing` + -- check already verified that all imported home modules are present there. + if not (isOldHomeDeps mname) + then return (UpToDate, []) + else do + mb_result <- getFromModIface "need mi_deps for" mod $ \imported_iface -> do + let mnames = mname:(map fst $ filter (not . snd) $ + dep_mods $ mi_deps imported_iface) + case find (not . isOldHomeDeps) mnames of + Nothing -> return (UpToDate, mnames) + Just new_dep_mname -> do + traceHiDiffs $ + text "imported home module " <> quotes (ppr mod) <> + text " has a new dependency " <> quotes (ppr new_dep_mname) + return (RecompBecause reason, []) + return $ fromMaybe (MustCompile, []) mb_result + + -- Performs all recompilation checks in the list until a check that yields + -- recompile required is encountered. Returns the list of the results of + -- all UpToDate checks. + runUntilRecompRequired [] = return (UpToDate, []) + runUntilRecompRequired (check:checks) = do + (recompile, value) <- check + if recompileRequired recompile + then return (recompile, []) + else do + (recomp, values) <- runUntilRecompRequired checks + return (recomp, value:values) + + checkIfAllOldHomeDependenciesAreSeen seen_deps = do + let unseen_old_deps = Set.difference + old_deps + seen_deps + if not (null unseen_old_deps) + then do + let missing_dep = Set.elemAt 0 unseen_old_deps + traceHiDiffs $ + text "missing old home dependency " <> quotes (ppr missing_dep) + return $ RecompBecause "missing old dependency" + else return UpToDate + +needInterface :: Module -> (ModIface -> IfG RecompileRequired) + -> IfG RecompileRequired +needInterface mod continue + = do + mb_recomp <- getFromModIface + "need version info for" + mod + continue + case mb_recomp of + Nothing -> return MustCompile + Just recomp -> return recomp + +getFromModIface :: String -> Module -> (ModIface -> IfG a) + -> IfG (Maybe a) +getFromModIface doc_msg mod getter + = do -- Load the imported interface if possible + let doc_str = sep [text doc_msg, ppr mod] + traceHiDiffs (text "Checking innterface for module" <+> ppr mod) + + mb_iface <- loadInterface doc_str mod ImportBySystem + -- Load the interface, but don't complain on failure; + -- Instead, get an Either back which we can test + + case mb_iface of + Failed _ -> do + traceHiDiffs (sep [text "Couldn't load interface for module", + ppr mod]) + return Nothing + -- Couldn't find or parse a module mentioned in the + -- old interface file. Don't complain: it might + -- just be that the current module doesn't need that + -- import and it's been deleted + Succeeded iface -> Just <$> getter iface + +-- | Given the usage information extracted from the old +-- M.hi file for the module being compiled, figure out +-- whether M needs to be recompiled. +checkModUsage :: UnitId -> Usage -> IfG RecompileRequired +checkModUsage _this_pkg UsagePackageModule{ + usg_mod = mod, + usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + -- We only track the ABI hash of package modules, rather than + -- individual entity usages, so if the ABI hash changes we must + -- recompile. This is safe but may entail more recompilation when + -- a dependent package has changed. + +checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } + = needInterface mod $ \iface -> do + let reason = moduleNameString (moduleName mod) ++ " changed (raw)" + checkModuleFingerprint reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) + +checkModUsage this_pkg UsageHomeModule{ + usg_mod_name = mod_name, + usg_mod_hash = old_mod_hash, + usg_exports = maybe_old_export_hash, + usg_entities = old_decl_hash } + = do + let mod = mkModule this_pkg mod_name + needInterface mod $ \iface -> do + + let + new_mod_hash = mi_mod_hash (mi_final_exts iface) + new_decl_hash = mi_hash_fn (mi_final_exts iface) + new_export_hash = mi_exp_hash (mi_final_exts iface) + + reason = moduleNameString mod_name ++ " changed" + + -- CHECK MODULE + recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash + if not (recompileRequired recompile) + then return UpToDate + else do + + -- CHECK EXPORT LIST + checkMaybeHash reason maybe_old_export_hash new_export_hash + (text " Export list changed") $ do + + -- CHECK ITEMS ONE BY ONE + recompile <- checkList [ checkEntityUsage reason new_decl_hash u + | u <- old_decl_hash] + if recompileRequired recompile + then return recompile -- This one failed, so just bail out now + else up_to_date (text " Great! The bits I use are up to date") + + +checkModUsage _this_pkg UsageFile{ usg_file_path = file, + usg_file_hash = old_hash } = + liftIO $ + handleIO handle $ do + new_hash <- getFileHash file + if (old_hash /= new_hash) + then return recomp + else return UpToDate + where + recomp = RecompBecause (file ++ " changed") + handle = +#if defined(DEBUG) + \e -> pprTrace "UsageFile" (text (show e)) $ return recomp +#else + \_ -> return recomp -- if we can't find the file, just recompile, don't fail +#endif + +------------------------ +checkModuleFingerprint :: String -> Fingerprint -> Fingerprint + -> IfG RecompileRequired +checkModuleFingerprint reason old_mod_hash new_mod_hash + | new_mod_hash == old_mod_hash + = up_to_date (text "Module fingerprint unchanged") + + | otherwise + = out_of_date_hash reason (text " Module fingerprint has changed") + old_mod_hash new_mod_hash + +------------------------ +checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc + -> IfG RecompileRequired -> IfG RecompileRequired +checkMaybeHash reason maybe_old_hash new_hash doc continue + | Just hash <- maybe_old_hash, hash /= new_hash + = out_of_date_hash reason doc hash new_hash + | otherwise + = continue + +------------------------ +checkEntityUsage :: String + -> (OccName -> Maybe (OccName, Fingerprint)) + -> (OccName, Fingerprint) + -> IfG RecompileRequired +checkEntityUsage reason new_hash (name,old_hash) + = case new_hash name of + + Nothing -> -- We used it before, but it ain't there now + out_of_date reason (sep [text "No longer exported:", ppr name]) + + Just (_, new_hash) -- It's there, but is it up to date? + | new_hash == old_hash -> do traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_hash)) + return UpToDate + | otherwise -> out_of_date_hash reason (text " Out of date:" <+> ppr name) + old_hash new_hash + +up_to_date :: SDoc -> IfG RecompileRequired +up_to_date msg = traceHiDiffs msg >> return UpToDate + +out_of_date :: String -> SDoc -> IfG RecompileRequired +out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason) + +out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired +out_of_date_hash reason msg old_hash new_hash + = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) + +---------------------- +checkList :: [IfG RecompileRequired] -> IfG RecompileRequired +-- This helper is used in two places +checkList [] = return UpToDate +checkList (check:checks) = do recompile <- check + if recompileRequired recompile + then return recompile + else checkList checks + +{- +************************************************************************ +* * + Converting things to their Iface equivalents +* * +************************************************************************ +-} + +tyThingToIfaceDecl :: TyThing -> IfaceDecl +tyThingToIfaceDecl (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only + PatSynCon ps -> patSynToIfaceDecl ps + +-------------------------- +idToIfaceDecl :: Id -> IfaceDecl +-- The Id is already tidied, so that locally-bound names +-- (lambdas, for-alls) already have non-clashing OccNames +-- We can't tidy it here, locally, because it may have +-- free variables in its type or IdInfo +idToIfaceDecl id + = IfaceId { ifName = getName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = toIfaceIdInfo (idInfo id) } + +-------------------------- +dataConToIfaceDecl :: DataCon -> IfaceDecl +dataConToIfaceDecl dataCon + = IfaceId { ifName = getName dataCon, + ifType = toIfaceType (dataConUserType dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = NoInfo } + +-------------------------- +coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl +-- We *do* tidy Axioms, because they are not (and cannot +-- conveniently be) built in tidy form +coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches + , co_ax_role = role }) + = IfaceAxiom { ifName = getName ax + , ifTyCon = toIfaceTyCon tycon + , ifRole = role + , ifAxBranches = map (coAxBranchToIfaceBranch tycon + (map coAxBranchLHS branch_list)) + branch_list } + where + branch_list = fromBranches branches + +-- 2nd parameter is the list of branch LHSs, in case of a closed type family, +-- for conversion from incompatible branches to incompatible indices. +-- For an open type family the list should be empty. +-- See Note [Storing compatibility] in CoAxiom +coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch +coAxBranchToIfaceBranch tc lhs_s + (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs, cab_roles = roles + , cab_rhs = rhs, cab_incomps = incomps }) + + = IfaceAxBranch { ifaxbTyVars = toIfaceTvBndrs tvs + , ifaxbCoVars = map toIfaceIdBndr cvs + , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs + , ifaxbLHS = toIfaceTcArgs tc lhs + , ifaxbRoles = roles + , ifaxbRHS = toIfaceType rhs + , ifaxbIncomps = iface_incomps } + where + iface_incomps = map (expectJust "iface_incomps" + . flip findIndex lhs_s + . eqTypes + . coAxBranchLHS) incomps + +----------------- +tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl) +-- We *do* tidy TyCons, because they are not (and cannot +-- conveniently be) built in tidy form +-- The returned TidyEnv is the one after tidying the tyConTyVars +tyConToIfaceDecl env tycon + | Just clas <- tyConClass_maybe tycon + = classToIfaceDecl env clas + + | Just syn_rhs <- synTyConRhs_maybe tycon + = ( tc_env1 + , IfaceSynonym { ifName = getName tycon, + ifRoles = tyConRoles tycon, + ifSynRhs = if_syn_type syn_rhs, + ifBinders = if_binders, + ifResKind = if_res_kind + }) + + | Just fam_flav <- famTyConFlav_maybe tycon + = ( tc_env1 + , IfaceFamily { ifName = getName tycon, + ifResVar = if_res_var, + ifFamFlav = to_if_fam_flav fam_flav, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifFamInj = tyConInjectivityInfo tycon + }) + + | isAlgTyCon tycon + = ( tc_env1 + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = tyConCType tycon, + ifRoles = tyConRoles tycon, + ifCtxt = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), + ifGadtSyntax = isGadtSyntaxTyCon tycon, + ifParent = parent }) + + | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon + -- We only convert these TyCons to IfaceTyCons when we are + -- just about to pretty-print them, not because we are going + -- to put them into interface files + = ( env + , IfaceData { ifName = getName tycon, + ifBinders = if_binders, + ifResKind = if_res_kind, + ifCType = Nothing, + ifRoles = tyConRoles tycon, + ifCtxt = [], + ifCons = IfDataTyCon [], + ifGadtSyntax = False, + ifParent = IfNoParent }) + where + -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon` + -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause + -- an error. + (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + tc_tyvars = binderVars tc_binders + if_binders = toIfaceTyCoVarBinders tc_binders + -- No tidying of the binders; they are already tidy + if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) + if_syn_type ty = tidyToIfaceType tc_env1 ty + if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon + + parent = case tyConFamInstSig_maybe tycon of + Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax) + (toIfaceTyCon tc) + (tidyToIfaceTcArgs tc_env1 tc ty) + Nothing -> IfNoParent + + to_if_fam_flav OpenSynFamilyTyCon = IfaceOpenSynFamilyTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon + to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing + to_if_fam_flav (ClosedSynFamilyTyCon (Just ax)) + = IfaceClosedSynFamilyTyCon (Just (axn, ibr)) + where defs = fromBranches $ coAxiomBranches ax + lhss = map coAxBranchLHS defs + ibr = map (coAxBranchToIfaceBranch tycon lhss) defs + axn = coAxiomName ax + + ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con] + ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The AbstractTyCon 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 and TupleTyCon cases are perfectly sensible. + -- (Tuple declarations are not serialised into interface files.) + + ifaceConDecl data_con + = IfCon { ifConName = dataConName data_con, + ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), + ifConExTCvs = map toIfaceBndr ex_tvs', + ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', + ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = map (tidyToIfaceType con_env2) arg_tys, + ifConFields = dataConFieldLabels data_con, + ifConStricts = map (toIfaceBang con_env2) + (dataConImplBangs data_con), + ifConSrcStricts = map toIfaceSrcBang + (dataConSrcBangs data_con)} + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) + = dataConFullSig data_con + user_bndrs = dataConUserTyVarBinders data_con + + -- Tidy the univ_tvs of the data constructor to be identical + -- to the tyConTyVars of the type constructor. This means + -- (a) we don't need to redundantly put them into the interface file + -- (b) when pretty-printing an Iface data declaration in H98-style syntax, + -- we know that the type variables will line up + -- The latter (b) is important because we pretty-print type constructors + -- by converting to Iface syntax and pretty-printing that + con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) + -- A bit grimy, perhaps, but it's simple! + + (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs + user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs + to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty) + + -- By this point, we have tidied every universal and existential + -- tyvar. Because of the dcUserTyCoVarBinders invariant + -- (see Note [DataCon user type variable binders]), *every* + -- user-written tyvar must be contained in the substitution that + -- tidying produced. Therefore, tidying the user-written tyvars is a + -- simple matter of looking up each variable in the substitution, + -- which tidyTyCoVarOcc accomplishes. + tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder + tidyUserTyCoVarBinder env (Bndr tv vis) = + Bndr (tidyTyCoVarOcc env tv) vis + +classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl) +classToIfaceDecl env clas + = ( env1 + , IfaceClass { ifName = getName tycon, + ifRoles = tyConRoles (classTyCon clas), + ifBinders = toIfaceTyCoVarBinders tc_binders, + ifBody = body, + ifFDs = map toIfaceFD clas_fds }) + where + (_, clas_fds, sc_theta, _, clas_ats, op_stuff) + = classExtraBigSig clas + tycon = classTyCon clas + + body | isAbstractTyCon tycon = IfAbstractClass + | otherwise + = IfConcreteClass { + ifClassCtxt = tidyToIfaceContext env1 sc_theta, + ifATs = map toIfaceAT clas_ats, + ifSigs = map toIfaceClassOp op_stuff, + ifMinDef = fmap getOccFS (classMinimalDef clas) + } + + (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) + + toIfaceAT :: ClassATItem -> IfaceAT + toIfaceAT (ATI tc def) + = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def) + where + (env2, if_decl) = tyConToIfaceDecl env1 tc + + toIfaceClassOp (sel_id, def_meth) + = ASSERT( sel_tyvars == binderVars tc_binders ) + IfaceClassOp (getName sel_id) + (tidyToIfaceType env1 op_ty) + (fmap toDmSpec def_meth) + 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 + + toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType + toDmSpec (_, VanillaDM) = VanillaDM + toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty) + + toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1 + ,map (tidyTyVar env1) tvs2) + +-------------------------- + +tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder) +-- If the type variable "binder" is in scope, don't re-bind it +-- In a class decl, for example, the ATD binders mention +-- (amd must mention) the class tyvars +tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) + = case lookupVarEnv subst tv of + Just tv' -> (env, Bndr tv' vis) + Nothing -> tidyTyCoVarBinder env tvb + +tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) +tidyTyConBinders = mapAccumL tidyTyConBinder + +tidyTyVar :: TidyEnv -> TyVar -> FastString +tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) + +-------------------------- +instanceToIfaceInst :: ClsInst -> IfaceClsInst +instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag + , is_cls_nm = cls_name, is_cls = cls + , is_tcs = mb_tcs + , is_orphan = orph }) + = ASSERT( cls_name == className cls ) + IfaceClsInst { ifDFun = dfun_name, + ifOFlag = oflag, + ifInstCls = cls_name, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + + dfun_name = idName dfun_id + + +-------------------------- +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst (FamInst { fi_axiom = axiom, + fi_fam = fam, + fi_tcs = roughs }) + = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom + , ifFamInstFam = fam + , ifFamInstTys = map do_rough roughs + , ifFamInstOrph = orph } + where + do_rough Nothing = Nothing + do_rough (Just n) = Just (toIfaceTyCon_name n) + + fam_decl = tyConName $ coAxiomTyCon axiom + mod = ASSERT( isExternalName (coAxiomName axiom) ) + nameModule (coAxiomName axiom) + is_local name = nameIsLocalOrFrom mod name + + lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom) + + orph | is_local fam_decl + = NotOrphan (nameOccName fam_decl) + | otherwise + = chooseOrphanAnchor lhs_names + +-------------------------- +coreRuleToIfaceRule :: CoreRule -> IfaceRule +coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule fn + +coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, + ru_orphan = orph, ru_auto = auto }) + = IfaceRule { ifRuleName = name, ifActivation = act, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr rhs, + ifRuleAuto = auto, + 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 (deNoteType ty)) + do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) + do_arg arg = toIfaceExpr arg + +bogusIfaceRule :: Name -> IfaceRule +bogusIfaceRule id_name + = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan, + ifRuleAuto = True } diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs new file mode 100644 index 0000000000..6b7b623389 --- /dev/null +++ b/compiler/GHC/IfaceToCore.hs @@ -0,0 +1,1825 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Type checking of type signatures in interface files +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE NondecreasingIndentation #-} + +module GHC.IfaceToCore ( + tcLookupImported_maybe, + importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + typecheckIfacesForMerging, + typecheckIfaceForInstantiate, + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceAnnotations, tcIfaceCompleteSigs, + tcIfaceExpr, -- Desired by HERMIT (#7683) + tcIfaceGlobal + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcTypeNats(typeNatCoAxiomRules) +import GHC.Iface.Syntax +import GHC.Iface.Load +import GHC.Iface.Env +import BuildTyCl +import TcRnMonad +import TcType +import Type +import Coercion +import CoAxiom +import TyCoRep -- needs to build types & coercions in a knot +import TyCoSubst ( substTyCoVars ) +import HscTypes +import Annotations +import InstEnv +import FamInstEnv +import CoreSyn +import CoreUtils +import CoreUnfold +import CoreLint +import MkCore +import Id +import MkId +import IdInfo +import Class +import TyCon +import ConLike +import DataCon +import PrelNames +import TysWiredIn +import Literal +import Var +import VarSet +import Name +import NameEnv +import NameSet +import OccurAnal ( occurAnalyseExpr ) +import Demand +import Module +import UniqFM +import UniqSupply +import Outputable +import Maybes +import SrcLoc +import DynFlags +import Util +import FastString +import BasicTypes hiding ( SuccessFlag(..) ) +import ListSetOps +import GHC.Fingerprint +import qualified BooleanFormula as BF + +import Control.Monad +import qualified Data.Map as Map + +{- +This module takes + + IfaceDecl -> TyThing + IfaceType -> Type + etc + +An IfaceDecl is populated with RdrNames, and these are not renamed to +Names before typechecking, because there should be no scope errors etc. + + -- For (b) consider: f = \$(...h....) + -- where h is imported, and calls f via an hi-boot file. + -- This is bad! But it is not seen as a staging error, because h + -- is indeed imported. We don't want the type-checker to black-hole + -- when simplifying and compiling the splice! + -- + -- Simple solution: discard any unfolding that mentions a variable + -- bound in this module (and hence not yet processed). + -- The discarding happens when forkM finds a type error. + + +************************************************************************ +* * + Type-checking a complete interface +* * +************************************************************************ + +Suppose we discover we don't need to recompile. Then we must type +check the old interface file. This is a bit different to the +incremental type checking we do as we suck in interface files. Instead +we do things similarly as when we are typechecking source decls: we +bring into scope the type envt for the interface all at once, using a +knot. Remember, the decls aren't necessarily in dependency order -- +and even if they were, the type decls might be mutually recursive. + +Note [Knot-tying typecheckIface] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are typechecking an interface A.hi, and we come across +a Name for another entity defined in A.hi. How do we get the +'TyCon', in this case? There are three cases: + + 1) tcHiBootIface in GHC.IfaceToCore: We're typechecking an + hi-boot file in preparation of checking if the hs file we're + building is compatible. In this case, we want all of the + internal TyCons to MATCH the ones that we just constructed + during typechecking: the knot is thus tied through if_rec_types. + + 2) retypecheckLoop in GhcMake: We are retypechecking a + mutually recursive cluster of hi files, in order to ensure + that all of the references refer to each other correctly. + In this case, the knot is tied through the HPT passed in, + which contains all of the interfaces we are in the process + of typechecking. + + 3) genModDetails in HscMain: We are typechecking an + old interface to generate the ModDetails. In this case, + we do the same thing as (2) and pass in an HPT with + the HomeModInfo being generated to tie knots. + +The upshot is that the CLIENT of this function is responsible +for making sure that the knot is tied correctly. If you don't, +then you'll get a message saying that we couldn't load the +declaration you wanted. + +BTW, in one-shot mode we never call typecheckIface; instead, +loadInterface handles type-checking interface. In that case, +knots are tied through the EPS. No problem! +-} + +-- Clients of this function be careful, see Note [Knot-tying typecheckIface] +typecheckIface :: ModIface -- Get the decls from here + -> IfG ModDetails +typecheckIface iface + = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do + { -- Get the right set of decls and rules. If we are compiling without -O + -- we discard pragmas before typechecking, so that we don't "see" + -- information that we shouldn't. From a versioning point of view + -- It's not actually *wrong* to do so, but in fact GHCi is unable + -- to handle unboxed tuples, so it must not see unfoldings. + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + + -- Typecheck the decls. This is done lazily, so that the knot-tying + -- within this single module works out right. It's the callers + -- job to make sure the knot is tied. + ; names_w_things <- loadDecls ignore_prags (mi_decls iface) + ; let type_env = mkNameEnv names_w_things + + -- Now do those rules, instances and annotations + ; insts <- mapM tcIfaceInst (mi_insts iface) + ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) + + -- Exports + ; exports <- ifaceExportNames (mi_exports iface) + + -- Complete Sigs + ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + + -- Finished + ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface), + -- Careful! If we tug on the TyThing thunks too early + -- we'll infinite loop with hs-boot. See #10083 for + -- an example where this would cause non-termination. + text "Type envt:" <+> ppr (map fst names_w_things)]) + ; return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_sigs = complete_sigs + } + } + +{- +************************************************************************ +* * + Typechecking for merging +* * +************************************************************************ +-} + +-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type) +isAbstractIfaceDecl :: IfaceDecl -> Bool +isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True +isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True +isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True +isAbstractIfaceDecl _ = False + +ifMaybeRoles :: IfaceDecl -> Maybe [Role] +ifMaybeRoles IfaceData { ifRoles = rs } = Just rs +ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs +ifMaybeRoles IfaceClass { ifRoles = rs } = Just rs +ifMaybeRoles _ = Nothing + +-- | Merge two 'IfaceDecl's together, preferring a non-abstract one. If +-- both are non-abstract we pick one arbitrarily (and check for consistency +-- later.) +mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl +mergeIfaceDecl d1 d2 + | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1 + | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2 + | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1 + , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2 + = let ops = nameEnvElts $ + plusNameEnv_C mergeIfaceClassOp + (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ]) + (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ]) + in d1 { ifBody = (ifBody d1) { + ifSigs = ops, + ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2] + } + } `withRolesFrom` d2 + -- It doesn't matter; we'll check for consistency later when + -- we merge, see 'mergeSignatures' + | otherwise = d1 `withRolesFrom` d2 + +-- Note [Role merging] +-- ~~~~~~~~~~~~~~~~~~~ +-- First, why might it be necessary to do a non-trivial role +-- merge? It may rescue a merge that might otherwise fail: +-- +-- signature A where +-- type role T nominal representational +-- data T a b +-- +-- signature A where +-- type role T representational nominal +-- data T a b +-- +-- A module that defines T as representational in both arguments +-- would successfully fill both signatures, so it would be better +-- if we merged the roles of these types in some nontrivial +-- way. +-- +-- However, we have to be very careful about how we go about +-- doing this, because role subtyping is *conditional* on +-- the supertype being NOT representationally injective, e.g., +-- if we have instead: +-- +-- signature A where +-- type role T nominal representational +-- data T a b = T a b +-- +-- signature A where +-- type role T representational nominal +-- data T a b = T a b +-- +-- Should we merge the definitions of T so that the roles are R/R (or N/N)? +-- Absolutely not: neither resulting type is a subtype of the original +-- types (see Note [Role subtyping]), because data is not representationally +-- injective. +-- +-- Thus, merging only occurs when BOTH TyCons in question are +-- representationally injective. If they're not, no merge. + +withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl +d1 `withRolesFrom` d2 + | Just roles1 <- ifMaybeRoles d1 + , Just roles2 <- ifMaybeRoles d2 + , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2) + = d1 { ifRoles = mergeRoles roles1 roles2 } + | otherwise = d1 + where + mergeRoles roles1 roles2 = zipWith max roles1 roles2 + +isRepInjectiveIfaceDecl :: IfaceDecl -> Bool +isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True +isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True +isRepInjectiveIfaceDecl _ = False + +mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp +mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1 +mergeIfaceClassOp _ op2 = op2 + +-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'. +mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl +mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl + +-- | This is a very interesting function. Like typecheckIface, we want +-- to type check an interface file into a ModDetails. However, the use-case +-- for these ModDetails is different: we want to compare all of the +-- ModDetails to ensure they define compatible declarations, and then +-- merge them together. So in particular, we have to take a different +-- strategy for knot-tying: we first speculatively merge the declarations +-- to get the "base" truth for what we believe the types will be +-- (this is "type computation.") Then we read everything in relative +-- to this truth and check for compatibility. +-- +-- During the merge process, we may need to nondeterministically +-- pick a particular declaration to use, if multiple signatures define +-- the declaration ('mergeIfaceDecl'). If, for all choices, there +-- are no type synonym cycles in the resulting merged graph, then +-- we can show that our choice cannot matter. Consider the +-- set of entities which the declarations depend on: by assumption +-- of acyclicity, we can assume that these have already been shown to be equal +-- to each other (otherwise merging will fail). Then it must +-- be the case that all candidate declarations here are type-equal +-- (the choice doesn't matter) or there is an inequality (in which +-- case merging will fail.) +-- +-- Unfortunately, the choice can matter if there is a cycle. Consider the +-- following merge: +-- +-- signature H where { type A = C; type B = A; data C } +-- signature H where { type A = (); data B; type C = B } +-- +-- If we pick @type A = C@ as our representative, there will be +-- a cycle and merging will fail. But if we pick @type A = ()@ as +-- our representative, no cycle occurs, and we instead conclude +-- that all of the types are unit. So it seems that we either +-- (a) need a stronger acyclicity check which considers *all* +-- possible choices from a merge, or (b) we must find a selection +-- of declarations which is acyclic, and show that this is always +-- the "best" choice we could have made (ezyang conjectures this +-- is the case but does not have a proof). For now this is +-- not implemented. +-- +-- It's worth noting that at the moment, a data constructor and a +-- type synonym are never compatible. Consider: +-- +-- signature H where { type Int=C; type B = Int; data C = Int} +-- signature H where { export Prelude.Int; data B; type C = B; } +-- +-- This will be rejected, because the reexported Int in the second +-- signature (a proper data type) is never considered equal to a +-- type synonym. Perhaps this should be relaxed, where a type synonym +-- in a signature is considered implemented by a data type declaration +-- which matches the reference of the type synonym. +typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails]) +typecheckIfacesForMerging mod ifaces tc_env_var = + -- cannot be boot (False) + initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- Build the initial environment + -- NB: Don't include dfuns here, because we don't want to + -- serialize them out. See Note [rnIfaceNeverExported] in GHC.Iface.Rename + -- NB: But coercions are OK, because they will have the right OccName. + let mk_decl_env decls + = mkOccEnv [ (getOccName decl, decl) + | decl <- decls + , case decl of + IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns + _ -> True ] + decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces + :: [OccEnv IfaceDecl] + decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs + :: OccEnv IfaceDecl + -- TODO: change loadDecls to accept w/o Fingerprint + names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x)) + (occEnvElts decl_env)) + let global_type_env = mkNameEnv names_w_things + writeMutVar tc_env_var global_type_env + + -- OK, now typecheck each ModIface using this environment + details <- forM ifaces $ \iface -> do + -- See Note [Resolving never-exported Names] in GHC.IfaceToCore + type_env <- fixM $ \type_env -> do + setImplicitEnvM type_env $ do + decls <- loadDecls ignore_prags (mi_decls iface) + return (mkNameEnv decls) + -- But note that we use this type_env to typecheck references to DFun + -- in 'IfaceInst' + setImplicitEnvM type_env $ do + insts <- mapM tcIfaceInst (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + exports <- ifaceExportNames (mi_exports iface) + complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_sigs = complete_sigs + } + return (global_type_env, details) + +-- | Typecheck a signature 'ModIface' under the assumption that we have +-- instantiated it under some implementation (recorded in 'mi_semantic_module') +-- and want to check if the implementation fills the signature. +-- +-- This needs to operate slightly differently than 'typecheckIface' +-- because (1) we have a 'NameShape', from the exports of the +-- implementing module, which we will use to give our top-level +-- declarations the correct 'Name's even when the implementor +-- provided them with a reexport, and (2) we have to deal with +-- DFun silliness (see Note [rnIfaceNeverExported]) +typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails +typecheckIfaceForInstantiate nsubst iface = + initIfaceLclWithSubst (mi_semantic_module iface) + (text "typecheckIfaceForInstantiate") + (mi_boot iface) nsubst $ do + ignore_prags <- goptM Opt_IgnoreInterfacePragmas + -- See Note [Resolving never-exported Names] in GHC.IfaceToCore + type_env <- fixM $ \type_env -> do + setImplicitEnvM type_env $ do + decls <- loadDecls ignore_prags (mi_decls iface) + return (mkNameEnv decls) + -- See Note [rnIfaceNeverExported] + setImplicitEnvM type_env $ do + insts <- mapM tcIfaceInst (mi_insts iface) + fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) + rules <- tcIfaceRules ignore_prags (mi_rules iface) + anns <- tcIfaceAnnotations (mi_anns iface) + exports <- ifaceExportNames (mi_exports iface) + complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface) + return $ ModDetails { md_types = type_env + , md_insts = insts + , md_fam_insts = fam_insts + , md_rules = rules + , md_anns = anns + , md_exports = exports + , md_complete_sigs = complete_sigs + } + +-- Note [Resolving never-exported Names] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For the high-level overview, see +-- Note [Handling never-exported TyThings under Backpack] +-- +-- As described in 'typecheckIfacesForMerging', the splendid innovation +-- of signature merging is to rewrite all Names in each of the signatures +-- we are merging together to a pre-merged structure; this is the key +-- ingredient that lets us solve some problems when merging type +-- synonyms. +-- +-- However, when a 'Name' refers to a NON-exported entity, as is the +-- case with the DFun of a ClsInst, or a CoAxiom of a type family, +-- this strategy causes problems: if we pick one and rewrite all +-- references to a shared 'Name', we will accidentally fail to check +-- if the DFun or CoAxioms are compatible, as they will never be +-- checked--only exported entities are checked for compatibility, +-- and a non-exported TyThing is checked WHEN we are checking the +-- ClsInst or type family for compatibility in checkBootDeclM. +-- By virtue of the fact that everything's been pointed to the merged +-- declaration, you'll never notice there's a difference even if there +-- is one. +-- +-- Fortunately, there are only a few places in the interface declarations +-- where this can occur, so we replace those calls with 'tcIfaceImplicit', +-- which will consult a local TypeEnv that records any never-exported +-- TyThings which we should wire up with. +-- +-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a +-- type family can refer to a coercion axiom, all of which are done in one go +-- when we typecheck 'mi_decls'. An alternate strategy would be to typecheck +-- coercions first before type families, but that seemed more fragile. +-- + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ +-} + +tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo +-- Load the hi-boot iface for the module being compiled, +-- if it indeed exists in the transitive closure of imports +-- Return the ModDetails; Nothing if no hi-boot iface +tcHiBootIface hsc_src mod + | HsBootFile <- hsc_src -- Already compiling a hs-boot file + = return NoSelfBoot + | otherwise + = do { traceIf (text "loadHiBootInterface" <+> ppr mod) + + ; mode <- getGhcMode + ; if not (isOneShot mode) + -- In --make and interactive mode, if this module has an hs-boot file + -- we'll have compiled it already, and it'll be in the HPT + -- + -- We check whether the interface is a *boot* interface. + -- It can happen (when using GHC from Visual Studio) that we + -- compile a module in TypecheckOnly mode, with a stable, + -- fully-populated HPT. In that case the boot interface isn't there + -- (it's been replaced by the mother module) so we can't check it. + -- And that's fine, because if M's ModInfo is in the HPT, then + -- it's been compiled once, and we don't need to check the boot iface + then do { hpt <- getHpt + ; case lookupHpt hpt (moduleName mod) of + Just info | mi_boot (hm_iface info) + -> mkSelfBootInfo (hm_iface info) (hm_details info) + _ -> return NoSelfBoot } + else do + + -- OK, so we're in one-shot mode. + -- Re #9245, we always check if there is an hi-boot interface + -- to check consistency against, rather than just when we notice + -- that an hi-boot is necessary due to a circular import. + { read_result <- findAndReadIface + need (fst (splitModuleInsts mod)) mod + True -- Hi-boot file + + ; case read_result of { + Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface + ; mkSelfBootInfo iface tc_iface } ; + Failed err -> + + -- There was no hi-boot file. But if there is circularity in + -- the module graph, there really should have been one. + -- Since we've read all the direct imports by now, + -- eps_is_boot will record if any of our imports mention the + -- current module, which either means a module loop (not + -- a SOURCE import) or that our hi-boot file has mysteriously + -- disappeared. + do { eps <- getEps + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of + Nothing -> return NoSelfBoot -- The typical case + + Just (_, False) -> failWithTc moduleLoop + -- Someone below us imported us! + -- This is a loop with no hi-boot in the way + + Just (_mod, True) -> failWithTc (elaborate err) + -- The hi-boot file has mysteriously disappeared. + }}}} + where + need = text "Need the hi-boot interface for" <+> ppr mod + <+> text "to compare against the Real Thing" + + moduleLoop = text "Circular imports: module" <+> quotes (ppr mod) + <+> text "depends on itself" + + elaborate err = hang (text "Could not find hi-boot interface for" <+> + quotes (ppr mod) <> colon) 4 err + + +mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo +mkSelfBootInfo iface mds + = do -- NB: This is computed DIRECTLY from the ModIface rather + -- than from the ModDetails, so that we can query 'sb_tcs' + -- WITHOUT forcing the contents of the interface. + let tcs = map ifName + . filter isIfaceTyCon + . map snd + $ mi_decls iface + return $ SelfBoot { sb_mds = mds + , sb_tcs = mkNameSet tcs } + where + -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on + -- this 'IfaceDecl', an ATyCon would be returned. + -- NB: This code assumes that a TyCon cannot be implicit. + isIfaceTyCon IfaceId{} = False + isIfaceTyCon IfaceData{} = True + isIfaceTyCon IfaceSynonym{} = True + isIfaceTyCon IfaceFamily{} = True + isIfaceTyCon IfaceClass{} = True + isIfaceTyCon IfaceAxiom{} = False + isIfaceTyCon IfacePatSyn{} = False + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +When typechecking a data type decl, we *lazily* (via forkM) typecheck +the constructor argument types. This is in the hope that we may never +poke on those argument types, and hence may never need to load the +interface files for types mentioned in the arg types. + +E.g. + data Foo.S = MkS Baz.T +Maybe we can get away without even loading the interface for Baz! + +This is not just a performance thing. Suppose we have + data Foo.S = MkS Baz.T + data Baz.T = MkT Foo.S +(in different interface files, of course). +Now, first we load and typecheck Foo.S, and add it to the type envt. +If we do explore MkS's argument, we'll load and typecheck Baz.T. +If we explore MkT's argument we'll find Foo.S already in the envt. + +If we typechecked constructor args eagerly, when loading Foo.S we'd try to +typecheck the type Baz.T. So we'd fault in Baz.T... and then need Foo.S... +which isn't done yet. + +All very cunning. However, there is a rather subtle gotcha which bit +me when developing this stuff. When we typecheck the decl for S, we +extend the type envt with S, MkS, and all its implicit Ids. Suppose +(a bug, but it happened) that the list of implicit Ids depended in +turn on the constructor arg types. Then the following sequence of +events takes place: + * we build a thunk <t> for the constructor arg tys + * we build a thunk for the extended type environment (depends on <t>) + * we write the extended type envt into the global EPS mutvar + +Now we look something up in the type envt + * that pulls on <t> + * which reads the global type envt out of the global EPS mutvar + * but that depends in turn on <t> + +It's subtle, because, it'd work fine if we typechecked the constructor args +eagerly -- they don't need the extended type envt. They just get the extended +type envt by accident, because they look at it later. + +What this means is that the implicitTyThings MUST NOT DEPEND on any of +the forkM stuff. +-} + +tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tcIfaceDecl = tc_iface_decl Nothing + +tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations + -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings + -> IfaceDecl + -> IfL TyThing +tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, + ifIdDetails = details, ifIdInfo = info}) + = do { ty <- tcIfaceType iface_type + ; details <- tcIdDetails ty details + ; info <- tcIdInfo ignore_prags TopLevel name ty info + ; return (AnId (mkGlobalId details name ty info)) } + +tc_iface_decl _ _ (IfaceData {ifName = tc_name, + ifCType = cType, + ifBinders = binders, + ifResKind = res_kind, + ifRoles = roles, + ifCtxt = ctxt, ifGadtSyntax = gadt_syn, + ifCons = rdr_cons, + ifParent = mb_parent }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind + + ; tycon <- fixM $ \ tycon -> do + { stupid_theta <- tcIfaceCtxt ctxt + ; parent' <- tc_parent tc_name mb_parent + ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons + ; return (mkAlgTyCon tc_name binders' res_kind' + roles cType stupid_theta + cons parent' gadt_syn) } + ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) + ; return (ATyCon tycon) } + where + tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav + tc_parent tc_name IfNoParent + = do { tc_rep_name <- newTyConRepName tc_name + ; return (VanillaAlgTyCon tc_rep_name) } + tc_parent _ (IfDataInstance ax_name _ arg_tys) + = do { ax <- tcIfaceCoAxiom ax_name + ; let fam_tc = coAxiomTyCon ax + ax_unbr = toUnbranchedAxiom ax + ; lhs_tys <- tcIfaceAppArgs arg_tys + ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } + +tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name, + ifRoles = roles, + ifSynRhs = rhs_ty, + ifBinders = binders, + ifResKind = res_kind }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tcIfaceType rhs_ty + ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs + ; return (ATyCon tycon) } + where + mk_doc n = text "Type synonym" <+> ppr n + +tc_iface_decl parent _ (IfaceFamily {ifName = tc_name, + ifFamFlav = fam_flav, + ifBinders = binders, + ifResKind = res_kind, + ifResVar = res, ifFamInj = inj }) + = bindIfaceTyConBinders_AT binders $ \ binders' -> do + { res_kind' <- tcIfaceType res_kind -- Note [Synonym kind loop] + ; rhs <- forkM (mk_doc tc_name) $ + tc_fam_flav tc_name fam_flav + ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res + ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj + ; return (ATyCon tycon) } + where + mk_doc n = text "Type synonym" <+> ppr n + + tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav + tc_fam_flav tc_name IfaceDataFamilyTyCon + = do { tc_rep_name <- newTyConRepName tc_name + ; return (DataFamilyTyCon tc_rep_name) } + tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon + tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches) + = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches + ; return (ClosedSynFamilyTyCon ax) } + tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon + = return AbstractClosedSynFamilyTyCon + tc_fam_flav _ IfaceBuiltInSynFamTyCon + = pprPanic "tc_iface_decl" + (text "IfaceBuiltInSynFamTyCon in interface file") + +tc_iface_decl _parent _ignore_prags + (IfaceClass {ifName = tc_name, + ifRoles = roles, + ifBinders = binders, + ifFDs = rdr_fds, + ifBody = IfAbstractClass}) + = bindIfaceTyConBinders binders $ \ binders' -> do + { fds <- mapM tc_fd rdr_fds + ; cls <- buildClass tc_name binders' roles fds Nothing + ; return (ATyCon (classTyCon cls)) } + +tc_iface_decl _parent ignore_prags + (IfaceClass {ifName = tc_name, + ifRoles = roles, + ifBinders = binders, + ifFDs = rdr_fds, + ifBody = IfConcreteClass { + ifClassCtxt = rdr_ctxt, + ifATs = rdr_ats, ifSigs = rdr_sigs, + ifMinDef = mindef_occ + }}) + = bindIfaceTyConBinders binders $ \ binders' -> do + { traceIf (text "tc-iface-class1" <+> ppr tc_name) + ; ctxt <- mapM tc_sc rdr_ctxt + ; traceIf (text "tc-iface-class2" <+> ppr tc_name) + ; sigs <- mapM tc_sig rdr_sigs + ; fds <- mapM tc_fd rdr_fds + ; traceIf (text "tc-iface-class3" <+> ppr tc_name) + ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ + ; cls <- fixM $ \ cls -> do + { ats <- mapM (tc_at cls) rdr_ats + ; traceIf (text "tc-iface-class4" <+> ppr tc_name) + ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) } + ; return (ATyCon (classTyCon cls)) } + where + tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred) + -- The *length* of the superclasses is used by buildClass, and hence must + -- not be inside the thunk. But the *content* maybe recursive and hence + -- must be lazy (via forkM). Example: + -- class C (T a) => D a where + -- data T a + -- Here the associated type T is knot-tied with the class, and + -- so we must not pull on T too eagerly. See #5970 + + tc_sig :: IfaceClassOp -> IfL TcMethInfo + tc_sig (IfaceClassOp op_name rdr_ty dm) + = do { let doc = mk_op_doc op_name rdr_ty + ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty + -- Must be done lazily for just the same reason as the + -- type of a data con; to avoid sucking in types that + -- it mentions unless it's necessary to do so + ; dm' <- tc_dm doc dm + ; return (op_name, op_ty, dm') } + + tc_dm :: SDoc + -> Maybe (DefMethSpec IfaceType) + -> IfL (Maybe (DefMethSpec (SrcSpan, Type))) + tc_dm _ Nothing = return Nothing + tc_dm _ (Just VanillaDM) = return (Just VanillaDM) + tc_dm doc (Just (GenericDM ty)) + = do { -- Must be done lazily to avoid sucking in types + ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty + ; return (Just (GenericDM (noSrcSpan, ty'))) } + + tc_at cls (IfaceAT tc_decl if_def) + = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl + mb_def <- case if_def of + Nothing -> return Nothing + Just def -> forkM (mk_at_doc tc) $ + extendIfaceTyVarEnv (tyConTyVars tc) $ + do { tc_def <- tcIfaceType def + ; return (Just (tc_def, noSrcSpan)) } + -- Must be done lazily in case the RHS of the defaults mention + -- the type constructor being defined here + -- e.g. type AT a; type AT b = AT [b] #8002 + return (ATI tc mb_def) + + mk_sc_doc pred = text "Superclass" <+> ppr pred + mk_at_doc tc = text "Associated type" <+> ppr tc + mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty] + +tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc + , ifAxBranches = branches, ifRole = role }) + = do { tc_tycon <- tcIfaceTyCon tc + -- Must be done lazily, because axioms are forced when checking + -- for family instance consistency, and the RHS may mention + -- a hs-boot declared type constructor that is going to be + -- defined by this module. + -- e.g. type instance F Int = ToBeDefined + -- See #13803 + ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name) + $ tc_ax_branches branches + ; let axiom = CoAxiom { co_ax_unique = nameUnique tc_name + , co_ax_name = tc_name + , co_ax_tc = tc_tycon + , co_ax_role = role + , co_ax_branches = manyBranches tc_branches + , co_ax_implicit = False } + ; return (ACoAxiom axiom) } + +tc_iface_decl _ _ (IfacePatSyn{ ifName = name + , ifPatMatcher = if_matcher + , ifPatBuilder = if_builder + , ifPatIsInfix = is_infix + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = field_labels }) + = do { traceIf (text "tc_iface_decl" <+> ppr name) + ; matcher <- tc_pr if_matcher + ; builder <- fmapMaybeM tc_pr if_builder + ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do + { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do + { patsyn <- forkM (mk_doc name) $ + do { prov_theta <- tcIfaceCtxt prov_ctxt + ; req_theta <- tcIfaceCtxt req_ctxt + ; pat_ty <- tcIfaceType pat_ty + ; arg_tys <- mapM tcIfaceType args + ; return $ buildPatSyn name is_infix matcher builder + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + arg_tys pat_ty field_labels } + ; return $ AConLike . PatSynCon $ patsyn }}} + where + mk_doc n = text "Pattern synonym" <+> ppr n + tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) + tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) + ; return (id, b) } + +tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) +tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1 + ; tvs2' <- mapM tcIfaceTyVar tvs2 + ; return (tvs1', tvs2') } + +tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch] +tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches + +tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch] +tc_ax_branch prev_branches + (IfaceAxBranch { ifaxbTyVars = tv_bndrs + , ifaxbEtaTyVars = eta_tv_bndrs + , ifaxbCoVars = cv_bndrs + , ifaxbLHS = lhs, ifaxbRHS = rhs + , ifaxbRoles = roles, ifaxbIncomps = incomps }) + = bindIfaceTyConBinders_AT + (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> + -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom + bindIfaceIds cv_bndrs $ \ cvs -> do + { tc_lhs <- tcIfaceAppArgs lhs + ; tc_rhs <- tcIfaceType rhs + ; eta_tvs <- bindIfaceTyVars eta_tv_bndrs return + ; this_mod <- getIfModule + ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS` + moduleNameFS (moduleName this_mod)) + br = CoAxBranch { cab_loc = loc + , cab_tvs = binderVars tvs + , cab_eta_tvs = eta_tvs + , cab_cvs = cvs + , cab_lhs = tc_lhs + , cab_roles = roles + , cab_rhs = tc_rhs + , cab_incomps = map (prev_branches `getNth`) incomps } + ; return (prev_branches ++ [br]) } + +tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tybinders if_cons + = case if_cons of + IfAbstractTyCon -> return AbstractTyCon + IfDataTyCon cons -> do { data_cons <- mapM tc_con_decl cons + ; return (mkDataTyConRhs data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; mkNewTyConRhs tycon_name tycon data_con } + where + univ_tvs :: [TyVar] + univ_tvs = binderVars (tyConTyVarBinders tc_tybinders) + + tag_map :: NameEnv ConTag + tag_map = mkTyConTagMap tycon + + tc_con_decl (IfCon { ifConInfix = is_infix, + ifConExTCvs = ex_bndrs, + ifConUserTvBinders = user_bndrs, + ifConName = dc_name, + ifConCtxt = ctxt, ifConEqSpec = spec, + ifConArgTys = args, ifConFields = lbl_names, + ifConStricts = if_stricts, + ifConSrcStricts = if_src_stricts}) + = -- Universally-quantified tyvars are shared with + -- parent TyCon, and are already in scope + bindIfaceBndrs ex_bndrs $ \ ex_tvs -> do + { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name) + + -- By this point, we have bound every universal and existential + -- tyvar. Because of the dcUserTyVarBinders invariant + -- (see Note [DataCon user type variable binders]), *every* tyvar in + -- ifConUserTvBinders has a matching counterpart somewhere in the + -- bound universals/existentials. As a result, calling tcIfaceTyVar + -- below is always guaranteed to succeed. + ; user_tv_bndrs <- mapM (\(Bndr bd vis) -> + case bd of + IfaceIdBndr (name, _) -> + Bndr <$> tcIfaceLclId name <*> pure vis + IfaceTvBndr (name, _) -> + Bndr <$> tcIfaceTyVar name <*> pure vis) + user_bndrs + + -- Read the context and argument types, but lazily for two reasons + -- (a) to avoid looking tugging on a recursive use of + -- the type itself, which is knot-tied + -- (b) to avoid faulting in the component types unless + -- they are really needed + ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $ + do { eq_spec <- tcIfaceEqSpec spec + ; theta <- tcIfaceCtxt ctxt + -- This fixes #13710. The enclosing lazy thunk gets + -- forced when typechecking record wildcard pattern + -- matching (it's not completely clear why this + -- tuple is needed), which causes trouble if one of + -- the argument types was recursively defined. + -- See also Note [Tying the knot] + ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys") + $ mapM tcIfaceType args + ; stricts <- mapM tc_strict if_stricts + -- The IfBang field can mention + -- the type itself; hence inside forkM + ; return (eq_spec, theta, arg_tys, stricts) } + + -- Remember, tycon is the representation tycon + ; let orig_res_ty = mkFamilyTyConApp tycon + (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec)) + (binderVars tc_tybinders)) + + ; prom_rep_name <- newTyConRepName dc_name + + ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) + dc_name is_infix prom_rep_name + (map src_strict if_src_stricts) + (Just stricts) + -- Pass the HsImplBangs (i.e. final + -- decisions) to buildDataCon; it'll use + -- these to guide the construction of a + -- worker. + -- See Note [Bangs on imported data constructors] in MkId + lbl_names + univ_tvs ex_tvs user_tv_bndrs + eq_spec theta + arg_tys orig_res_ty tycon tag_map + ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) + ; return con } + mk_doc con_name = text "Constructor" <+> ppr con_name + + tc_strict :: IfaceBang -> IfL HsImplBang + tc_strict IfNoBang = return (HsLazy) + tc_strict IfStrict = return (HsStrict) + tc_strict IfUnpack = return (HsUnpack Nothing) + tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co + ; return (HsUnpack (Just co)) } + + src_strict :: IfaceSrcBang -> HsSrcBang + src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang + +tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec] +tcIfaceEqSpec spec + = mapM do_item spec + where + do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ + ; ty <- tcIfaceType if_ty + ; return (mkEqSpec tv ty) } + +{- +Note [Synonym kind loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we eagerly grab the *kind* from the interface file, but +build a forkM thunk for the *rhs* (and family stuff). To see why, +consider this (#2412) + +M.hs: module M where { import X; data T = MkT S } +X.hs: module X where { import {-# SOURCE #-} M; type S = T } +M.hs-boot: module M where { data T } + +When kind-checking M.hs we need S's kind. But we do not want to +find S's kind from (typeKind S-rhs), because we don't want to look at +S-rhs yet! Since S is imported from X.hi, S gets just one chance to +be defined, and we must not do that until we've finished with M.T. + +Solution: record S's kind in the interface file; now we can safely +look at it. + +************************************************************************ +* * + Instances +* * +************************************************************************ +-} + +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ + fmap tyThingId (tcIfaceImplicit dfun_name) + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } + +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = axiom_name } ) + = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $ + tcIfaceCoAxiom axiom_name + -- will panic if branched, but that's OK + ; let axiom'' = toUnbranchedAxiom axiom' + mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' axiom'') } + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ + +We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars +are in the type environment. However, remember that typechecking a Rule may +(as a side effect) augment the type envt, and so we may need to iterate the process. +-} + +tcIfaceRules :: Bool -- True <=> ignore rules + -> [IfaceRule] + -> IfL [CoreRule] +tcIfaceRules ignore_prags if_rules + | ignore_prags = return [] + | otherwise = mapM tcIfaceRule if_rules + +tcIfaceRule :: IfaceRule -> IfL CoreRule +tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleAuto = auto, ifRuleOrph = orph }) + = do { ~(bndrs', args', rhs') <- + -- Typecheck the payload lazily, in the hope it'll never be looked at + forkM (text "Rule" <+> pprRuleName name) $ + bindIfaceBndrs bndrs $ \ bndrs' -> + do { args' <- mapM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; return (bndrs', args', rhs') } + ; let mb_tcs = map ifTopFreeName args + ; this_mod <- getIfModule + ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs', ru_args = args', + ru_rhs = occurAnalyseExpr rhs', + ru_rough = mb_tcs, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = auto, + ru_local = False }) } -- An imported RULE is never for a local Id + -- or, even if it is (module loop, perhaps) + -- we'll just leave it in the non-local set + where + -- This function *must* mirror exactly what Rules.roughTopNames does + -- We could have stored the ru_rough field in the iface file + -- but that would be redundant, I think. + -- The only wrinkle is that we must not be deceived by + -- type synonyms at the top of a type arg. Since + -- we can't tell at this point, we are careful not + -- to write them out in coreRuleToIfaceRule + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts))) + ifTopFreeName (IfaceApp f _) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName _ = Nothing + +{- +************************************************************************ +* * + Annotations +* * +************************************************************************ +-} + +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceAnnotations = mapM tcIfaceAnnotation + +tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation +tcIfaceAnnotation (IfaceAnnotation target serialized) = do + target' <- tcIfaceAnnTarget target + return $ Annotation { + ann_target = target', + ann_value = serialized + } + +tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name) +tcIfaceAnnTarget (NamedTarget occ) = do + name <- lookupIfaceTop occ + return $ NamedTarget name +tcIfaceAnnTarget (ModuleTarget mod) = do + return $ ModuleTarget mod + +{- +************************************************************************ +* * + Complete Match Pragmas +* * +************************************************************************ +-} + +tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] +tcIfaceCompleteSigs = mapM tcIfaceCompleteSig + +tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch +tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +tcIfaceType :: IfaceType -> IfL Type +tcIfaceType = go + where + go (IfaceTyVar n) = TyVarTy <$> tcIfaceTyVar n + go (IfaceFreeTyVar n) = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n) + go (IfaceLitTy l) = LitTy <$> tcIfaceTyLit l + go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2 + go (IfaceTupleTy s i tks) = tcIfaceTupleTy s i tks + go (IfaceAppTy t ts) + = do { t' <- go t + ; ts' <- traverse go (appArgsIfaceTypes ts) + ; pure (foldl' AppTy t' ts') } + go (IfaceTyConApp tc tks) + = do { tc' <- tcIfaceTyCon tc + ; tks' <- mapM go (appArgsIfaceTypes tks) + ; return (mkTyConApp tc' tks') } + go (IfaceForAllTy bndr t) + = bindIfaceForAllBndr bndr $ \ tv' vis -> + ForAllTy (Bndr tv' vis) <$> go t + go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co + go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co + +tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type +tcIfaceTupleTy sort is_promoted args + = do { args' <- tcIfaceAppArgs args + ; let arity = length args' + ; base_tc <- tcTupleTyCon True sort arity + ; case is_promoted of + NotPromoted + -> return (mkTyConApp base_tc args') + + IsPromoted + -> do { let tc = promoteDataCon (tyConSingleDataCon base_tc) + kind_args = map typeKind args' + ; return (mkTyConApp tc (kind_args ++ args')) } } + +-- See Note [Unboxed tuple RuntimeRep vars] in TyCon +tcTupleTyCon :: Bool -- True <=> typechecking a *type* (vs. an expr) + -> TupleSort + -> Arity -- the number of args. *not* the tuple arity. + -> IfL TyCon +tcTupleTyCon in_type sort arity + = case sort of + ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity) + ; return (tyThingTyCon thing) } + BoxedTuple -> return (tupleTyCon Boxed arity) + UnboxedTuple -> return (tupleTyCon Unboxed arity') + where arity' | in_type = arity `div` 2 + | otherwise = arity + -- in expressions, we only have term args + +tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type] +tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes + +----------------------------------------- +tcIfaceCtxt :: IfaceContext -> IfL ThetaType +tcIfaceCtxt sts = mapM tcIfaceType sts + +----------------------------------------- +tcIfaceTyLit :: IfaceTyLit -> IfL TyLit +tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) +tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) + +{- +%************************************************************************ +%* * + Coercions +* * +************************************************************************ +-} + +tcIfaceCo :: IfaceCoercion -> IfL Coercion +tcIfaceCo = go + where + go_mco IfaceMRefl = pure MRefl + go_mco (IfaceMCo co) = MCo <$> (go co) + + go (IfaceReflCo t) = Refl <$> tcIfaceType t + go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco + go (IfaceFunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 + go (IfaceTyConAppCo r tc cs) + = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs + go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceForAllCo tv k c) = do { k' <- go k + ; bindIfaceBndr tv $ \ tv' -> + ForAllCo tv' k' <$> go c } + go (IfaceCoVarCo n) = CoVarCo <$> go_var n + go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs + go (IfaceUnivCo p r t1 t2) = UnivCo <$> tcIfaceUnivCoProv p <*> pure r + <*> tcIfaceType t1 <*> tcIfaceType t2 + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 + <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 + <*> go t2 + go (IfaceNthCo d c) = do { c' <- go c + ; return $ mkNthCo (nthCoRole d c') d c' } + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c + go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax + <*> mapM go cos + go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) + go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) + + go_var :: FastString -> IfL CoVar + go_var = tcIfaceLclId + +tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance +tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv +tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco +tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str + +{- +************************************************************************ +* * + Core +* * +************************************************************************ +-} + +tcIfaceExpr :: IfaceExpr -> IfL CoreExpr +tcIfaceExpr (IfaceType ty) + = Type <$> tcIfaceType ty + +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + +tcIfaceExpr (IfaceLcl name) + = Var <$> tcIfaceLclId name + +tcIfaceExpr (IfaceExt gbl) + = Var <$> tcIfaceExtId gbl + +tcIfaceExpr (IfaceLit lit) + = do lit' <- tcIfaceLit lit + return (Lit lit') + +tcIfaceExpr (IfaceFCall cc ty) = do + ty' <- tcIfaceType ty + u <- newUnique + dflags <- getDynFlags + return (Var (mkFCallId dflags u cc ty')) + +tcIfaceExpr (IfaceTuple sort args) + = do { args' <- mapM tcIfaceExpr args + ; tc <- tcTupleTyCon False sort arity + ; let con_tys = map exprType args' + some_con_args = map Type con_tys ++ args' + con_args = case sort of + UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args + _ -> some_con_args + -- Put the missing type arguments back in + con_id = dataConWorkId (tyConSingleDataCon tc) + ; return (mkApps (Var con_id) con_args) } + where + arity = length args + +tcIfaceExpr (IfaceLam (bndr, os) body) + = bindIfaceBndr bndr $ \bndr' -> + Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body + where + tcIfaceOneShot IfaceOneShot b = setOneShotLambda b + tcIfaceOneShot _ b = b + +tcIfaceExpr (IfaceApp fun arg) + = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg + +tcIfaceExpr (IfaceECase scrut ty) + = do { scrut' <- tcIfaceExpr scrut + ; ty' <- tcIfaceType ty + ; return (castBottomExpr scrut' ty') } + +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do + scrut' <- tcIfaceExpr scrut + case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) + let + scrut_ty = exprType scrut' + case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty + -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors + -- (e.g. see test T15695). Ticket #17291 covers fixing this problem. + tc_app = splitTyConApp scrut_ty + -- NB: Won't always succeed (polymorphic case) + -- but won't be demanded in those cases + -- NB: not tcSplitTyConApp; we are looking at Core here + -- look through non-rec newtypes to find the tycon that + -- corresponds to the datacon in this case alternative + + extendIfaceIdEnv [case_bndr'] $ do + alts' <- mapM (tcIfaceAlt scrut' tc_app) alts + return (Case scrut' case_bndr' (coreAltsType alts') alts') + +tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + NotTopLevel name ty' info + ; let id = mkLocalIdWithInfo name ty' id_info + `asJoinId_maybe` tcJoinInfo ji + ; rhs' <- tcIfaceExpr rhs + ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body) + ; return (Let (NonRec id rhs') body') } + +tcIfaceExpr (IfaceLet (IfaceRec pairs) body) + = do { ids <- mapM tc_rec_bndr (map fst pairs) + ; extendIfaceIdEnv ids $ do + { pairs' <- zipWithM tc_pair pairs ids + ; body' <- tcIfaceExpr body + ; return (Let (Rec pairs') body') } } + where + tc_rec_bndr (IfLetBndr fs ty _ ji) + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; return (mkLocalId name ty' `asJoinId_maybe` tcJoinInfo ji) } + tc_pair (IfLetBndr _ _ info _, rhs) id + = do { rhs' <- tcIfaceExpr rhs + ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -} + NotTopLevel (idName id) (idType id) info + ; return (setIdInfo id id_info, rhs') } + +tcIfaceExpr (IfaceTick tickish expr) = do + expr' <- tcIfaceExpr expr + -- If debug flag is not set: Ignore source notes + dbgLvl <- fmap debugLevel getDynFlags + case tickish of + IfaceSource{} | dbgLvl == 0 + -> return expr' + _otherwise -> do + tickish' <- tcIfaceTickish tickish + return (Tick tickish' expr') + +------------------------- +tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id) +tcIfaceTickish (IfaceHpcTick modl ix) = return (HpcTick modl ix) +tcIfaceTickish (IfaceSCC cc tick push) = return (ProfNote cc tick push) +tcIfaceTickish (IfaceSource src name) = return (SourceNote src name) + +------------------------- +tcIfaceLit :: Literal -> IfL Literal +-- Integer literals deserialise to (LitInteger i <error thunk>) +-- so tcIfaceLit just fills in the type. +-- See Note [Integer literals] in Literal +tcIfaceLit (LitNumber LitNumInteger i _) + = do t <- tcIfaceTyConByName integerTyConName + return (mkLitInteger i (mkTyConTy t)) +-- Natural literals deserialise to (LitNatural i <error thunk>) +-- so tcIfaceLit just fills in the type. +-- See Note [Natural literals] in Literal +tcIfaceLit (LitNumber LitNumNatural i _) + = do t <- tcIfaceTyConByName naturalTyConName + return (mkLitNatural i (mkTyConTy t)) +tcIfaceLit lit = return lit + +------------------------- +tcIfaceAlt :: CoreExpr -> (TyCon, [Type]) + -> (IfaceConAlt, [FastString], IfaceExpr) + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceAlt _ _ (IfaceDefault, names, rhs) + = ASSERT( null names ) do + rhs' <- tcIfaceExpr rhs + return (DEFAULT, [], rhs') + +tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs) + = ASSERT( null names ) do + lit' <- tcIfaceLit lit + rhs' <- tcIfaceExpr rhs + return (LitAlt lit', [], rhs') + +-- A case alternative is made quite a bit more complicated +-- by the fact that we omit type annotations because we can +-- work them out. True enough, but its not that easy! +tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) + = do { con <- tcIfaceDataCon data_occ + ; when (debugIsOn && not (con `elem` tyConDataCons tycon)) + (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon))) + ; tcIfaceDataAlt con inst_tys arg_strs rhs } + +tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr + -> IfL (AltCon, [TyVar], CoreExpr) +tcIfaceDataAlt con inst_tys arg_strs rhs + = do { us <- newUniqueSupply + ; let uniqs = uniqsFromSupply us + ; let (ex_tvs, arg_ids) + = dataConRepFSInstPat arg_strs uniqs con inst_tys + + ; rhs' <- extendIfaceEnvs ex_tvs $ + extendIfaceIdEnv arg_ids $ + tcIfaceExpr rhs + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } + +{- +************************************************************************ +* * + IdInfo +* * +************************************************************************ +-} + +tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails +tcIdDetails _ IfVanillaId = return VanillaId +tcIdDetails ty IfDFunId + = return (DFunId (isNewTyCon (classTyCon cls))) + where + (_, _, cls, _) = tcSplitDFunTy ty + +tcIdDetails _ (IfRecSelId tc naughty) + = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) + (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) + tc + ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + where + tyThingPatSyn (AConLike (PatSynCon ps)) = ps + tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" + +tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo +tcIdInfo ignore_prags toplvl name ty info = do + lcl_env <- getLclEnv + -- Set the CgInfo to something sensible but uninformative before + -- we start; default assumption is that it has CAFs + let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding + | otherwise = vanillaIdInfo + if ignore_prags + then return init_info + else case info of + NoInfo -> return init_info + HasInfo info -> foldlM tcPrag init_info info + where + tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo + tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs) + tcPrag info (HsArity arity) = return (info `setArityInfo` arity) + tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str) + tcPrag info (HsInline prag) = return (info `setInlinePragInfo` prag) + tcPrag info HsLevity = return (info `setNeverLevPoly` ty) + + -- The next two are lazy, so they don't transitively suck stuff in + tcPrag info (HsUnfold lb if_unf) + = do { unf <- tcUnfolding toplvl name ty info if_unf + ; let info1 | lb = info `setOccInfo` strongLoopBreaker + | otherwise = info + ; return (info1 `setUnfoldingInfo` unf) } + +tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity +tcJoinInfo (IfaceJoinPoint ar) = Just ar +tcJoinInfo IfaceNotJoinPoint = Nothing + +tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding +tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr) + = do { dflags <- getDynFlags + ; mb_expr <- tcPragExpr toplvl name if_expr + ; let unf_src | stable = InlineStable + | otherwise = InlineRhs + ; return $ case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkUnfolding dflags unf_src + True {- Top level -} + (isBottomingSig strict_sig) + expr + } + where + -- Strictness should occur before unfolding! + strict_sig = strictnessInfo info +tcUnfolding toplvl name _ _ (IfCompulsory if_expr) + = do { mb_expr <- tcPragExpr toplvl name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCompulsoryUnfolding expr) } + +tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr) + = do { mb_expr <- tcPragExpr toplvl name if_expr + ; return (case mb_expr of + Nothing -> NoUnfolding + Just expr -> mkCoreUnfolding InlineStable True expr guidance )} + where + guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + +tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops) + = bindIfaceBndrs bs $ \ bs' -> + do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops + ; return (case mb_ops1 of + Nothing -> noUnfolding + Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) } + where + doc = text "Class ops for dfun" <+> ppr name + (_, _, cls, _) = tcSplitDFunTy dfun_ty + +{- +For unfoldings we try to do the job lazily, so that we never type check +an unfolding that isn't going to be looked at. +-} + +tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr) +tcPragExpr toplvl name expr + = forkM_maybe doc $ do + core_expr' <- tcIfaceExpr expr + + -- Check for type consistency in the unfolding + -- See Note [Linting Unfoldings from Interfaces] + when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do + in_scope <- get_in_scope + dflags <- getDynFlags + case lintUnfolding dflags noSrcLoc in_scope core_expr' of + Nothing -> return () + Just fail_msg -> do { mod <- getIfModule + ; pprPanic "Iface Lint failure" + (vcat [ text "In interface for" <+> ppr mod + , hang doc 2 fail_msg + , ppr name <+> equals <+> ppr core_expr' + , text "Iface expr =" <+> ppr expr ]) } + return core_expr' + where + doc = text "Unfolding of" <+> ppr name + + get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting + get_in_scope + = do { (gbl_env, lcl_env) <- getEnvs + ; rec_ids <- case if_rec_types gbl_env of + Nothing -> return [] + Just (_, get_env) -> do + { type_env <- setLclEnv () get_env + ; return (typeEnvIds type_env) } + ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet` + bindingsVars (if_id_env lcl_env) `unionVarSet` + mkVarSet rec_ids) } + + bindingsVars :: FastStringEnv Var -> VarSet + bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm + -- It's OK to use nonDetEltsUFM here because we immediately forget + -- the ordering by creating a set + +{- +************************************************************************ +* * + Getting from Names to TyThings +* * +************************************************************************ +-} + +tcIfaceGlobal :: Name -> IfL TyThing +tcIfaceGlobal name + | Just thing <- wiredInNameTyThing_maybe name + -- Wired-in things include TyCons, DataCons, and Ids + -- Even though we are in an interface file, we want to make + -- sure the instances and RULES of this thing (particularly TyCon) are loaded + -- Imagine: f :: Double -> Double + = do { ifCheckWiredInThing thing; return thing } + + | otherwise + = do { env <- getGblEnv + ; case if_rec_types env of { -- Note [Tying the knot] + Just (mod, get_type_env) + | nameIsLocalOrFrom mod name + -> do -- It's defined in the module being compiled + { type_env <- setLclEnv () get_type_env -- yuk + ; case lookupNameEnv type_env name of + Just thing -> return thing + -- See Note [Knot-tying fallback on boot] + Nothing -> via_external + } + + ; _ -> via_external }} + where + via_external = do + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { + Just thing -> return thing ; + Nothing -> do + + { mb_thing <- importDecl name -- It's imported; go get it + ; case mb_thing of + Failed err -> failIfM err + Succeeded thing -> return thing + }}} + +-- Note [Tying the knot] +-- ~~~~~~~~~~~~~~~~~~~~~ +-- The if_rec_types field is used when we are compiling M.hs, which indirectly +-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type +-- environment, which is splatted into if_rec_types after we've built M's type +-- envt. +-- +-- This is a dark and complicated part of GHC type checking, with a lot +-- of moving parts. Interested readers should also look at: +-- +-- * Note [Knot-tying typecheckIface] +-- * Note [DFun knot-tying] +-- * Note [hsc_type_env_var hack] +-- * Note [Knot-tying fallback on boot] +-- +-- There is also a wiki page on the subject, see: +-- +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot + +-- Note [Knot-tying fallback on boot] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Suppose that you are typechecking A.hs, which transitively imports, +-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it +-- has a reference to a type T from A, what TyThing should we wire +-- it up with? Clearly, if we have already typechecked T and +-- added it into the type environment, we should go ahead and use that +-- type. But what if we haven't typechecked it yet? +-- +-- For the longest time, GHC adopted the policy that this was +-- *an error condition*; that you MUST NEVER poke on B.hs's reference +-- to a T defined in A.hs until A.hs has gotten around to kind-checking +-- T and adding it to the env. However, actually ensuring this is the +-- case has proven to be a bug farm, because it's really difficult to +-- actually ensure this never happens. The problem was especially poignant +-- with type family consistency checks, which eagerly happen before any +-- typechecking takes place. +-- +-- Today, we take a different strategy: if we ever try to access +-- an entity from A which doesn't exist, we just fall back on the +-- definition of A from the hs-boot file. This is complicated in +-- its own way: it means that you may end up with a mix of A.hs and +-- A.hs-boot TyThings during the course of typechecking. We don't +-- think (and have not observed) any cases where this would cause +-- problems, but the hypothetical situation one might worry about +-- is something along these lines in Core: +-- +-- case x of +-- A -> e1 +-- B -> e2 +-- +-- If, when typechecking this, we find x :: T, and the T we are hooked +-- up with is the abstract one from the hs-boot file, rather than the +-- one defined in this module with constructors A and B. But it's hard +-- to see how this could happen, especially because the reference to +-- the constructor (A and B) means that GHC will always typecheck +-- this expression *after* typechecking T. + +tcIfaceTyConByName :: IfExtName -> IfL TyCon +tcIfaceTyConByName name + = do { thing <- tcIfaceGlobal name + ; return (tyThingTyCon thing) } + +tcIfaceTyCon :: IfaceTyCon -> IfL TyCon +tcIfaceTyCon (IfaceTyCon name info) + = do { thing <- tcIfaceGlobal name + ; return $ case ifaceTyConIsPromoted info of + NotPromoted -> tyThingTyCon thing + IsPromoted -> promoteDataCon $ tyThingDataCon thing } + +tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched) +tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name + ; return (tyThingCoAxiom thing) } + + +tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule +-- Unlike CoAxioms, which arise form user 'type instance' declarations, +-- there are a fixed set of CoAxiomRules, +-- currently enumerated in typeNatCoAxiomRules +tcIfaceCoAxiomRule n + = case Map.lookup n typeNatCoAxiomRules of + Just ax -> return ax + _ -> pprPanic "tcIfaceCoAxiomRule" (ppr n) + +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of + AConLike (RealDataCon dc) -> return dc + _ -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } + +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of + AnId id -> return id + _ -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } + +-- See Note [Resolving never-exported Names] in GHC.IfaceToCore +tcIfaceImplicit :: Name -> IfL TyThing +tcIfaceImplicit n = do + lcl_env <- getLclEnv + case if_implicits_env lcl_env of + Nothing -> tcIfaceGlobal n + Just tenv -> + case lookupTypeEnv tenv n of + Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv) + Just tything -> return tything + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ +-} + +bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a +bindIfaceId (fs, ty) thing_inside + = do { name <- newIfaceName (mkVarOccFS fs) + ; ty' <- tcIfaceType ty + ; let id = mkLocalIdOrCoVar name ty' + -- We should not have "OrCoVar" here, this is a bug (#17545) + ; extendIfaceIdEnv [id] (thing_inside id) } + +bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a +bindIfaceIds [] thing_inside = thing_inside [] +bindIfaceIds (b:bs) thing_inside + = bindIfaceId b $ \b' -> + bindIfaceIds bs $ \bs' -> + thing_inside (b':bs') + +bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a +bindIfaceBndr (IfaceIdBndr bndr) thing_inside + = bindIfaceId bndr thing_inside +bindIfaceBndr (IfaceTvBndr bndr) thing_inside + = bindIfaceTyVar bndr thing_inside + +bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a +bindIfaceBndrs [] thing_inside = thing_inside [] +bindIfaceBndrs (b:bs) thing_inside + = bindIfaceBndr b $ \ b' -> + bindIfaceBndrs bs $ \ bs' -> + thing_inside (b':bs') + +----------------------- +bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a +bindIfaceForAllBndrs [] thing_inside = thing_inside [] +bindIfaceForAllBndrs (bndr:bndrs) thing_inside + = bindIfaceForAllBndr bndr $ \tv vis -> + bindIfaceForAllBndrs bndrs $ \bndrs' -> + thing_inside (mkTyCoVarBinder vis tv : bndrs') + +bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a +bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside + = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis +bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside + = bindIfaceId tv $ \tv' -> thing_inside tv' vis + +bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a +bindIfaceTyVar (occ,kind) thing_inside + = do { name <- newIfaceName (mkTyVarOccFS occ) + ; tyvar <- mk_iface_tyvar name kind + ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) } + +bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a +bindIfaceTyVars [] thing_inside = thing_inside [] +bindIfaceTyVars (bndr:bndrs) thing_inside + = bindIfaceTyVar bndr $ \tv -> + bindIfaceTyVars bndrs $ \tvs -> + thing_inside (tv : tvs) + +mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar +mk_iface_tyvar name ifKind + = do { kind <- tcIfaceType ifKind + ; return (Var.mkTyVar name kind) } + +bindIfaceTyConBinders :: [IfaceTyConBinder] + -> ([TyConBinder] -> IfL a) -> IfL a +bindIfaceTyConBinders [] thing_inside = thing_inside [] +bindIfaceTyConBinders (b:bs) thing_inside + = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' -> + bindIfaceTyConBinders bs $ \ bs' -> + thing_inside (b':bs') + +bindIfaceTyConBinders_AT :: [IfaceTyConBinder] + -> ([TyConBinder] -> IfL a) -> IfL a +-- Used for type variable in nested associated data/type declarations +-- where some of the type variables are already in scope +-- class C a where { data T a b } +-- Here 'a' is in scope when we look at the 'data T' +bindIfaceTyConBinders_AT [] thing_inside + = thing_inside [] +bindIfaceTyConBinders_AT (b : bs) thing_inside + = bindIfaceTyConBinderX bind_tv b $ \b' -> + bindIfaceTyConBinders_AT bs $ \bs' -> + thing_inside (b':bs') + where + bind_tv tv thing + = do { mb_tv <- lookupIfaceVar tv + ; case mb_tv of + Just b' -> thing b' + Nothing -> bindIfaceBndr tv thing } + +bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a) + -> IfaceTyConBinder + -> (TyConBinder -> IfL a) -> IfL a +bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside + = bind_tv tv $ \tv' -> + thing_inside (Bndr tv' vis) diff --git a/compiler/GHC/IfaceToCore.hs-boot b/compiler/GHC/IfaceToCore.hs-boot new file mode 100644 index 0000000000..4a888f51f7 --- /dev/null +++ b/compiler/GHC/IfaceToCore.hs-boot @@ -0,0 +1,20 @@ +module GHC.IfaceToCore where + +import GhcPrelude +import GHC.Iface.Syntax + ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule + , IfaceAnnotation, IfaceCompleteMatch ) +import TyCoRep ( TyThing ) +import TcRnTypes ( IfL ) +import InstEnv ( ClsInst ) +import FamInstEnv ( FamInst ) +import CoreSyn ( CoreRule ) +import HscTypes ( CompleteMatch ) +import Annotations ( Annotation ) + +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceInst :: IfaceClsInst -> IfL ClsInst +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] +tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch] diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index b82fea5de2..256be34ce8 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -479,13 +479,13 @@ stgRhsArity (StgRhsCon _ _ _) = 0 -- ~~~~~~~~~~~~~~~~~~~~~~ -- -- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in --- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with +-- `CoreToStg`) to make sure CAF-ness predicted by `GHC.Iface.Tidy` is consistent with -- reality. -- -- Specifically, if the RHS mentions any Id that itself is marked -- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the -- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble --- is that `TidyPgm` computed the CAF info on the `Id` but some transformations +-- is that `GHC.Iface.Tidy` computed the CAF info on the `Id` but some transformations -- have taken place since then. topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool @@ -547,7 +547,7 @@ stgArgHasCafRefs _ stgIdHasCafRefs :: Id -> Bool stgIdHasCafRefs id = -- We are looking for occurrences of an Id that is bound at top level, and may - -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether + -- have CAF refs. At this point (after GHC.Iface.Tidy) top-level Ids (whether -- imported or defined in this module) are GlobalIds, so the test is easy. isGlobalId id && mayHaveCafRefs (idCafInfo id) |