diff options
Diffstat (limited to 'compiler/iface/BuildTyCl.hs')
| -rw-r--r-- | compiler/iface/BuildTyCl.hs | 137 |
1 files changed, 38 insertions, 99 deletions
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 76b7793859..693e2899c8 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -6,15 +6,17 @@ {-# LANGUAGE CPP #-} module BuildTyCl ( - buildDataCon, mkDataConUnivTyVarBinders, + buildDataCon, buildPatSyn, - TcMethInfo, buildClass, - mkNewTyConRhs, mkDataTyConRhs, + TcMethInfo, MethInfo, buildClass, + mkNewTyConRhs, newImplicitBinder, newTyConRepName ) where #include "HsVersions.h" +import GhcPrelude + import IfaceEnv import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom ) import TysWiredIn( isCTupleTyConName ) @@ -25,6 +27,7 @@ import Var import VarSet import BasicTypes import Name +import NameEnv import MkId import Class import TyCon @@ -39,19 +42,6 @@ import UniqSupply import Util import Outputable -mkDataTyConRhs :: [DataCon] -> AlgTyConRhs -mkDataTyConRhs cons - = DataTyCon { - data_cons = cons, - is_enum = not (null cons) && all is_enum_con cons - -- See Note [Enumeration types] in TyCon - } - where - is_enum_con con - | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) - <- dataConFullSig con - = null ex_tvs && null eq_spec && null theta && null arg_tys - mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs -- ^ Monadic because it makes a Name for the coercion TyCon @@ -70,9 +60,12 @@ mkNewTyConRhs tycon_name tycon con where tvs = tyConTyVars tycon roles = tyConRoles tycon - inst_con_ty = piResultTys (dataConUserType con) (mkTyVarTys tvs) - rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty - -- Instantiate the data con with the + con_arg_ty = case dataConRepArgTys con of + [arg_ty] -> arg_ty + tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys) + rhs_ty = substTyWith (dataConUnivTyVars con) + (mkTyVarTys tvs) con_arg_ty + -- Instantiate the newtype's RHS with the -- type variables from the tycon -- NB: a newtype DataCon has a type that must look like -- forall tvs. <arg-ty> -> T tvs @@ -107,21 +100,25 @@ buildDataCon :: FamInstEnvs -> Maybe [HsImplBang] -- See Note [Bangs on imported data constructors] in MkId -> [FieldLabel] -- Field labels - -> [TyVarBinder] -- Universals - -> [TyVarBinder] -- Existentials + -> [TyVar] -- Universals + -> [TyCoVar] -- Existentials + -> [TyVarBinder] -- User-written 'TyVarBinder's -> [EqSpec] -- Equality spec - -> ThetaType -- Does not include the "stupid theta" + -> KnotTied ThetaType -- Does not include the "stupid theta" -- or the GADT equalities - -> [Type] -> Type -- Argument and result types - -> TyCon -- Rep tycon + -> [KnotTied Type] -- Arguments + -> KnotTied Type -- Result types + -> KnotTied TyCon -- Rep tycon + -> NameEnv ConTag -- Maps the Name of each DataCon to its + -- ConTag -> TcRnIf m n DataCon -- A wrapper for DataCon.mkDataCon that -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) --- c) Sorts out the TyVarBinders. See mkDataConUnivTyBinders -buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls - univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon +buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs + field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty + rep_tycon tag_map = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc -- This last one takes the name of the data constructor in the source @@ -132,10 +129,12 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie ; us <- newUniqueSupply ; dflags <- getDynFlags ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs + tag = lookupNameEnv_NF tag_map src_name + -- See Note [Constructor tag allocation], fixes #14657 data_con = mkDataCon src_name declared_infix prom_info src_bangs field_lbls - univ_tvs ex_tvs eq_spec ctxt - arg_tys res_ty NoRRI rep_tycon + univ_tvs ex_tvs user_tvbs eq_spec ctxt + arg_tys res_ty NoRRI rep_tycon tag stupid_ctxt dc_wrk dc_rep dc_wrk = mkDataConWorkId work_name data_con dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name @@ -149,13 +148,13 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs fie -- the type variables mentioned in the arg_tys -- ToDo: Or functionally dependent on? -- This whole stupid theta thing is, well, stupid. -mkDataConStupidTheta :: TyCon -> [Type] -> [TyVarBinder] -> [PredType] +mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType] mkDataConStupidTheta tycon arg_tys univ_tvs | null stupid_theta = [] -- The common case | otherwise = filter in_arg_tys stupid_theta where tc_subst = zipTvSubst (tyConTyVars tycon) - (mkTyVarTys (binderVars univ_tvs)) + (mkTyVarTys univ_tvs) stupid_theta = substTheta tc_subst (tyConStupidTheta tycon) -- Start by instantiating the master copy of the -- stupid theta, taken from the TyCon @@ -165,69 +164,6 @@ mkDataConStupidTheta tycon arg_tys univ_tvs tyCoVarsOfType pred `intersectVarSet` arg_tyvars -mkDataConUnivTyVarBinders :: [TyConBinder] -- From the TyCon - -> [TyVarBinder] -- For the DataCon --- See Note [Building the TyBinders for a DataCon] -mkDataConUnivTyVarBinders tc_bndrs - = map mk_binder tc_bndrs - where - mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv - where - vis = case tc_vis of - AnonTCB -> Specified - NamedTCB Required -> Specified - NamedTCB vis -> vis - -{- Note [Building the TyBinders for a DataCon] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A DataCon needs to keep track of the visibility of its universals and -existentials, so that visible type application can work properly. This -is done by storing the universal and existential TyVarBinders. -See Note [TyVarBinders in DataCons] in DataCon. - -During construction of a DataCon, we often start from the TyBinders of -the parent TyCon. For example - data Maybe a = Nothing | Just a -The DataCons start from the TyBinders of the parent TyCon. - -But the ultimate TyBinders for the DataCon are *different* than those -of the DataCon. Here is an example: - - data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * - -The TyCon has - - tyConTyVars = [ k:*, a:k->*, b:k] - tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ] - -The TyBinders for App line up with App's kind, given above. - -But the DataCon MkApp has the type - MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b - -That is, its TyBinders should be - - dataConUnivTyVarBinders = [ TvBndr (k:*) Inferred - , TvBndr (a:k->*) Specified - , TvBndr (b:k) Specified ] - -So we want to take the TyCon's TyBinders and the TyCon's TyVars and -merge them, pulling - - variable names from the TyVars - - visibilities from the TyBinders - - but changing Anon/Required to Specified - -The last part about Required->Specified comes from this: - data T k (a:k) b = MkT (a b) -Here k is Required in T's kind, but we don't have Required binders in -the TyBinders for a term (see Note [No Required TyBinder in terms] -in TyCoRep), so we change it to Specified when making MkT's TyBinders - -This merging operation is done by mkDataConUnivTyBinders. In contrast, -the TyBinders passed to mkDataCon are the final TyBinders stored in the -DataCon (mkDataCon does no further work). --} - ------------------------------------------------------ buildPatSyn :: Name -> Bool -> (Id,Bool) -> Maybe (Id, Bool) @@ -278,7 +214,8 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder ------------------------------------------------------ -type TcMethInfo -- A temporary intermediate, to communicate +type TcMethInfo = MethInfo -- this variant needs zonking +type MethInfo -- A temporary intermediate, to communicate -- between tcClassSigs and buildClass. = ( Name -- Name of the class op , Type -- Type of the class op @@ -302,7 +239,7 @@ buildClass :: Name -- Name of the class/tycon (they have the same Name) -> [FunDep TyVar] -- Functional dependencies -- Super classes, associated types, method info, minimal complete def. -- This is Nothing if the class is abstract. - -> Maybe (ThetaType, [ClassATItem], [TcMethInfo], ClassMinimalDef) + -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef) -> TcRnIf m n Class buildClass tycon_name binders roles fds Nothing @@ -310,7 +247,7 @@ buildClass tycon_name binders roles fds Nothing do { traceIf (text "buildClass") ; tc_rep_name <- newTyConRepName tycon_name - ; let univ_bndrs = mkDataConUnivTyVarBinders binders + ; let univ_bndrs = tyConTyVarBinders binders univ_tvs = binderVars univ_bndrs tycon = mkClassTyCon tycon_name binders roles AbstractTyCon rec_clas tc_rep_name @@ -359,7 +296,7 @@ buildClass tycon_name binders roles fds op_names = [op | (op,_,_) <- sig_stuff] arg_tys = sc_theta ++ op_tys rec_tycon = classTyCon rec_clas - univ_bndrs = mkDataConUnivTyVarBinders binders + univ_bndrs = tyConTyVarBinders binders univ_tvs = binderVars univ_bndrs ; rep_nm <- newTyConRepName datacon_name @@ -370,13 +307,15 @@ buildClass tycon_name binders roles fds (map (const no_bang) args) (Just (map (const HsLazy) args)) [{- No fields -}] - univ_bndrs + univ_tvs [{- no existentials -}] + univ_bndrs [{- No GADT equalities -}] [{- No theta -}] arg_tys (mkTyConApp rec_tycon (mkTyVarTys univ_tvs)) rec_tycon + (mkTyConTagMap rec_tycon) ; rhs <- case () of _ | use_newtype |