From d69cbd78999071d2d6479be40ae90ddd83b9942a Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 10 May 2023 14:38:55 +0200 Subject: Split up tyThingToIfaceDecl from GHC.Iface.Make This commit moves tyThingToIfaceDecl and coAxiomToIfaceDecl from GHC.Iface.Make into GHC.Iface.Decl. This avoids GHC.Types.TyThing.Ppr, which needs tyThingToIfaceDecl, transitively depending on e.g. GHC.Iface.Load and GHC.Tc.Utils.Monad. --- compiler/GHC/Iface/Decl.hs | 334 +++++++++++++++++ compiler/GHC/Iface/Make.hs | 421 ++++------------------ compiler/GHC/Tc/Module.hs | 6 +- compiler/GHC/Types/TyThing/Ppr.hs | 2 +- compiler/ghc.cabal.in | 1 + testsuite/tests/count-deps/CountDepsAst.stdout | 1 + testsuite/tests/count-deps/CountDepsParser.stdout | 1 + 7 files changed, 404 insertions(+), 362 deletions(-) create mode 100644 compiler/GHC/Iface/Decl.hs diff --git a/compiler/GHC/Iface/Decl.hs b/compiler/GHC/Iface/Decl.hs new file mode 100644 index 0000000000..c645fc5166 --- /dev/null +++ b/compiler/GHC/Iface/Decl.hs @@ -0,0 +1,334 @@ + +{-# LANGUAGE NondecreasingIndentation #-} + +{- +(c) The University of Glasgow 2006-2008 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +-- | Module for constructing interface declaration values +-- from the corresponding 'TyThing's. + +module GHC.Iface.Decl + ( coAxiomToIfaceDecl + , tyThingToIfaceDecl -- Converting things to their Iface equivalents + ) +where + +import GHC.Prelude + +import GHC.Tc.Utils.TcType + +import GHC.Iface.Syntax + +import GHC.CoreToIface + +import GHC.Core.Class +import GHC.Core.TyCon +import GHC.Core.Coercion.Axiom +import GHC.Core.ConLike +import GHC.Core.DataCon +import GHC.Core.Type +import GHC.Core.Multiplicity + + +import GHC.Types.Id +import GHC.Types.Var.Env +import GHC.Types.Var +import GHC.Types.Name +import GHC.Types.Basic +import GHC.Types.TyThing + +import GHC.Utils.Panic.Plain +import GHC.Utils.Misc + +import GHC.Data.FastString +import GHC.Data.Maybe + +import Data.List ( findIndex, mapAccumL ) + +{- +************************************************************************ +* * + Converting things to their Iface equivalents +* * +************************************************************************ +-} + +tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl +tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id +tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) +tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax +tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of + RealDataCon dc -> dataConToIfaceDecl show_linear_types 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 :: Bool -> DataCon -> IfaceDecl +dataConToIfaceDecl show_linear_types dataCon + = IfaceId { ifName = getName dataCon, + ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), + ifIdDetails = IfVanillaId, + ifIdInfo = [] } + +-------------------------- +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 GHC.Core.Coercion.Axiom +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_maybe 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 False [], + 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 = toIfaceForAllBndrs 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, is_type_data = type_data }) + = IfDataTyCon type_data (map ifaceConDecl cons) + ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon False [ifaceConDecl con] + ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon False (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = IfAbstractTyCon + -- The AbstractTyCon case happens when a TyCon has been trimmed + -- during tidying. + -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module + -- 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 = toIfaceForAllBndrs user_bndrs', + ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, + ifConCtxt = tidyToIfaceContext con_env2 theta, + ifConArgTys = + map (\(Scaled w t) -> (tidyToIfaceType con_env2 w + , (tidyToIfaceType con_env2 t))) 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 (tidyUserForAllTyBinder 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 dcUserForAllTyBinders 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. + tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder + tidyUserForAllTyBinder 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 = toIfaceForAllBndrs 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) = splitForAllTyCoVars (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 -> tidyForAllTyBinder env tvb + +tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) +tidyTyConBinders = mapAccumL tidyTyConBinder + +tidyTyVar :: TidyEnv -> TyVar -> FastString +tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index 3f6ef4b465..d20ff6dad3 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -14,8 +14,6 @@ module GHC.Iface.Make , mkFullIface , mkIfaceTc , mkIfaceExports - , coAxiomToIfaceDecl - , tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where @@ -29,6 +27,7 @@ import GHC.StgToCmm.Types (CmmCgInfos (..)) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad +import GHC.Iface.Decl import GHC.Iface.Syntax import GHC.Iface.Recomp import GHC.Iface.Load @@ -39,12 +38,8 @@ import GHC.CoreToIface import qualified GHC.LanguageExtensions as LangExt import GHC.Core import GHC.Core.Class -import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.ConLike -import GHC.Core.DataCon -import GHC.Core.Type -import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core.Ppr @@ -60,15 +55,12 @@ import GHC.Types.Id import GHC.Types.Fixity.Env import GHC.Types.SafeHaskell import GHC.Types.Annotations -import GHC.Types.Var.Env -import GHC.Types.Var import GHC.Types.Name import GHC.Types.Avail import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Unique.DSet -import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Types.TypeEnv import GHC.Types.SourceFile import GHC.Types.TyThing @@ -78,7 +70,6 @@ import GHC.Types.CompleteMatch import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain -import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Data.FastString @@ -96,7 +87,7 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Deps import Data.Function -import Data.List ( findIndex, mapAccumL, sortBy ) +import Data.List ( sortBy ) import Data.Ord import Data.IORef @@ -369,353 +360,6 @@ mkIface_ hsc_env ifFamInstTcName = ifFamInstFam -{- -************************************************************************ -* * - COMPLETE Pragmas -* * -************************************************************************ --} - -mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch -mkIfaceCompleteMatch (CompleteMatch cls mtc) = - IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc) - - -{- -************************************************************************ -* * - 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 []) = AvailTC n [] - sort_subs (AvailTC n (m:ms)) - | n == m - = AvailTC n (m:sortBy stableNameCmp ms) - | otherwise - = AvailTC n (sortBy stableNameCmp (m:ms)) - -- Maintain the AvailTC Invariant - -{- -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. --} - - -{- -************************************************************************ -* * - Converting things to their Iface equivalents -* * -************************************************************************ --} - -tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl -tyThingToIfaceDecl _ (AnId id) = idToIfaceDecl id -tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) -tyThingToIfaceDecl _ (ACoAxiom ax) = coAxiomToIfaceDecl ax -tyThingToIfaceDecl show_linear_types (AConLike cl) = case cl of - RealDataCon dc -> dataConToIfaceDecl show_linear_types 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 :: Bool -> DataCon -> IfaceDecl -dataConToIfaceDecl show_linear_types dataCon - = IfaceId { ifName = getName dataCon, - ifType = toIfaceType (dataConDisplayType show_linear_types dataCon), - ifIdDetails = IfVanillaId, - ifIdInfo = [] } - --------------------------- -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 GHC.Core.Coercion.Axiom -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_maybe 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 False [], - 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 = toIfaceForAllBndrs 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, is_type_data = type_data }) - = IfDataTyCon type_data (map ifaceConDecl cons) - ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon False [ifaceConDecl con] - ifaceConDecls (SumTyCon { data_cons = cons }) = IfDataTyCon False (map ifaceConDecl cons) - ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The AbstractTyCon case happens when a TyCon has been trimmed - -- during tidying. - -- Furthermore, tyThingToIfaceDecl is also used in GHC.Tc.Module - -- 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 = toIfaceForAllBndrs user_bndrs', - ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, - ifConCtxt = tidyToIfaceContext con_env2 theta, - ifConArgTys = - map (\(Scaled w t) -> (tidyToIfaceType con_env2 w - , (tidyToIfaceType con_env2 t))) 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 (tidyUserForAllTyBinder 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 dcUserForAllTyBinders 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. - tidyUserForAllTyBinder :: TidyEnv -> InvisTVBinder -> InvisTVBinder - tidyUserForAllTyBinder 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 = toIfaceForAllBndrs 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) = splitForAllTyCoVars (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 -> tidyForAllTyBinder 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 @@ -776,3 +420,64 @@ coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) do_arg (Coercion co) = IfaceCo (toIfaceCoercion co) do_arg arg = toIfaceExpr arg + + +{- +************************************************************************ +* * + COMPLETE Pragmas +* * +************************************************************************ +-} + +mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch +mkIfaceCompleteMatch (CompleteMatch cls mtc) = + IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc) + + +{- +************************************************************************ +* * + 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 []) = AvailTC n [] + sort_subs (AvailTC n (m:ms)) + | n == m + = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise + = AvailTC n (sortBy stableNameCmp (m:ms)) + -- Maintain the AvailTC Invariant + +{- +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. +-} diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index b9153b6473..5c381f9e70 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -98,10 +98,10 @@ import GHC.Rename.Module import GHC.Rename.Doc import GHC.Rename.Utils ( mkNameClashErr ) -import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) -import GHC.Iface.Type ( ShowForAllFlag(..) ) +import GHC.Iface.Decl ( coAxiomToIfaceDecl ) +import GHC.Iface.Syntax ( ShowSub(..), showToHeader ) +import GHC.Iface.Type ( ShowForAllFlag(..) ) import GHC.Iface.Env ( externaliseName ) -import GHC.Iface.Make ( coAxiomToIfaceDecl ) import GHC.Iface.Load import GHC.Builtin.Types ( mkListTy, anyTypeOfKind ) diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs index 04b6225bd8..2982635815 100644 --- a/compiler/GHC/Types/TyThing/Ppr.hs +++ b/compiler/GHC/Types/TyThing/Ppr.hs @@ -26,9 +26,9 @@ import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) ) import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) +import GHC.Iface.Decl ( tyThingToIfaceDecl ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl ) -import GHC.Iface.Make ( tyThingToIfaceDecl ) import GHC.Utils.Outputable diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 15c3b39550..684e99c815 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -511,6 +511,7 @@ Library GHC.Hs.Type GHC.Hs.Utils GHC.Iface.Binary + GHC.Iface.Decl GHC.Iface.Env GHC.Iface.Errors GHC.Iface.Errors.Types diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 2493a0a9b1..549f9bd371 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -142,6 +142,7 @@ GHC.HsToCore.Errors.Types GHC.HsToCore.Pmc.Ppr GHC.HsToCore.Pmc.Solver.Types GHC.HsToCore.Pmc.Types +GHC.Iface.Decl GHC.Iface.Errors.Ppr GHC.Iface.Errors.Types GHC.Iface.Ext.Fields diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index 2b74bda834..639d765427 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -143,6 +143,7 @@ GHC.HsToCore.Errors.Types GHC.HsToCore.Pmc.Ppr GHC.HsToCore.Pmc.Solver.Types GHC.HsToCore.Pmc.Types +GHC.Iface.Decl GHC.Iface.Errors.Ppr GHC.Iface.Errors.Types GHC.Iface.Ext.Fields -- cgit v1.2.1