summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorsheaf <sam.derbyshire@gmail.com>2023-05-10 14:38:55 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-05-15 18:03:00 -0400
commitd69cbd78999071d2d6479be40ae90ddd83b9942a (patch)
tree33fe1e02ae939ed8c51b795954bc5ada7a5fbcad
parent451d65a6913d85088a350be8e9b7a6d834453326 (diff)
downloadhaskell-d69cbd78999071d2d6479be40ae90ddd83b9942a.tar.gz
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.
-rw-r--r--compiler/GHC/Iface/Decl.hs334
-rw-r--r--compiler/GHC/Iface/Make.hs421
-rw-r--r--compiler/GHC/Tc/Module.hs6
-rw-r--r--compiler/GHC/Types/TyThing/Ppr.hs2
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--testsuite/tests/count-deps/CountDepsAst.stdout1
-rw-r--r--testsuite/tests/count-deps/CountDepsParser.stdout1
7 files changed, 404 insertions, 362 deletions
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