diff options
55 files changed, 1883 insertions, 996 deletions
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs index 51f312f975..3ae01d72b8 100644 --- a/compiler/backpack/RnModIface.hs +++ b/compiler/backpack/RnModIface.hs @@ -524,7 +524,7 @@ rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon rnIfaceConDecl :: Rename IfaceConDecl rnIfaceConDecl d = do con_name <- rnIfaceGlobal (ifConName d) - con_ex_tvs <- mapM rnIfaceTvBndr (ifConExTvs 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) @@ -535,7 +535,7 @@ rnIfaceConDecl d = do rnIfaceBang bang = pure bang con_stricts <- mapM rnIfaceBang (ifConStricts d) return d { ifConName = con_name - , ifConExTvs = con_ex_tvs + , ifConExTCvs = con_ex_tvs , ifConUserTvBinders = con_user_tvbs , ifConEqSpec = con_eq_spec , ifConCtxt = con_ctxt @@ -624,7 +624,7 @@ rnIfaceTvBndr :: Rename IfaceTvBndr rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind rnIfaceTyConBinder :: Rename IfaceTyConBinder -rnIfaceTyConBinder (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis +rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis rnIfaceAlt :: Rename IfaceAlt rnIfaceAlt (conalt, names, rhs) @@ -656,7 +656,7 @@ rnIfaceCo (IfaceTyConAppCo role tc cos) rnIfaceCo (IfaceAppCo co1 co2) = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 rnIfaceCo (IfaceForAllCo bndr co1 co2) - = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo 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 @@ -711,7 +711,7 @@ rnIfaceType (IfaceCastTy ty co) = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co rnIfaceForAllBndr :: Rename IfaceForAllBndr -rnIfaceForAllBndr (TvBndr tv vis) = TvBndr <$> rnIfaceTvBndr tv <*> pure vis +rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis rnIfaceAppArgs :: Rename IfaceAppArgs rnIfaceAppArgs (IA_Invis t ts) = IA_Invis <$> rnIfaceType t <*> rnIfaceAppArgs ts diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs index f1fc03b332..a9d7548b8a 100644 --- a/compiler/basicTypes/ConLike.hs +++ b/compiler/basicTypes/ConLike.hs @@ -12,7 +12,7 @@ module ConLike ( , conLikeArity , conLikeFieldLabels , conLikeInstOrigArgTys - , conLikeExTyVars + , conLikeExTyCoVars , conLikeName , conLikeStupidTheta , conLikeWrapId_maybe @@ -113,10 +113,10 @@ conLikeInstOrigArgTys (RealDataCon data_con) tys = conLikeInstOrigArgTys (PatSynCon pat_syn) tys = patSynInstArgTys pat_syn tys --- | Existentially quantified type variables -conLikeExTyVars :: ConLike -> [TyVar] -conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1 -conLikeExTyVars (PatSynCon psyn1) = patSynExTyVars psyn1 +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 conLikeName :: ConLike -> Name conLikeName (RealDataCon data_con) = dataConName data_con @@ -152,7 +152,7 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- -- 1) The universally quantified type variables -- --- 2) The existentially quantified type variables +-- 2) The existentially quantified type/coercion variables -- -- 3) The equality specification -- @@ -165,7 +165,9 @@ conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys -- -- 7) The original result type conLikeFullSig :: ConLike - -> ([TyVar], [TyVar], [EqSpec] + -> ([TyVar], [TyCoVar], [EqSpec] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in DataCon , ThetaType, ThetaType, [Type], Type) conLikeFullSig (RealDataCon con) = let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 9b62c27df3..b7435e5b54 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -31,7 +31,7 @@ module DataCon ( dataConName, dataConIdentity, dataConTag, dataConTagZ, dataConTyCon, dataConOrigTyCon, dataConUserType, - dataConUnivTyVars, dataConExTyVars, dataConUnivAndExTyVars, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, dataConUserTyVars, dataConUserTyVarBinders, dataConEqSpec, dataConTheta, dataConStupidTheta, @@ -288,19 +288,19 @@ data DataCon -- e.g. -- -- dcUnivTyVars = [a,b,c] - -- dcExTyVars = [x,y] + -- dcExTyCoVars = [x,y] -- dcUserTyVarBinders = [c,y,x,b] -- dcEqSpec = [a~(x,y)] -- dcOtherTheta = [x~y, Ord x] -- dcOrigArgTys = [x,y] -- dcRepTyCon = T - -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS - -- FOR THE PARENT TyCon. (This is a change (Oct05): previously, vanilla - -- datacons guaranteed to have the same type variables as their parent TyCon, - -- but that seems ugly.) They can be different in the case where a GADT - -- constructor uses different names for the universal tyvars than does - -- the tycon. For example: + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: -- -- data H a where -- MkH :: b -> H b @@ -312,7 +312,7 @@ data DataCon -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = [] + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. @@ -323,23 +323,28 @@ data DataCon -- INVARIANT: result type of data con worker is exactly (T a b c) -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with -- the tyConTyVars of the parent TyCon - dcUnivTyVars :: [TyVar], + dcUnivTyVars :: [TyVar], - -- Existentially-quantified type vars [x,y] - dcExTyVars :: [TyVar], + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why tycovars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], - -- INVARIANT: the UnivTyVars and ExTyVars all have distinct OccNames + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames -- Reason: less confusing, and easier to generate IfaceSyn - -- The type vars in the order the user wrote them [c,y,x,b] - -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the - -- set of dcExTyVars unioned with the set of dcUnivTyVars - -- whose tyvars do not appear in dcEqSpec + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set + -- of tyvars (*not* covars) of dcExTyCoVars unioned with the + -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec -- See Note [DataCon user type variable binders] dcUserTyVarBinders :: [TyVarBinder], dcEqSpec :: [EqSpec], -- Equalities derived from the result type, - -- _as written by the programmer_ + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). -- This field allows us to move conveniently between the two ways -- of representing a GADT constructor's type: @@ -403,7 +408,7 @@ data DataCon dcRep :: DataConRep, -- Cached; see Note [DataCon arities] - -- INVARIANT: dcRepArity == length dataConRepArgTys + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) -- INVARIANT: dcSourceArity == length dcOrigArgTys dcRepArity :: Arity, dcSourceArity :: Arity, @@ -441,7 +446,7 @@ For the TyVarBinders in a DataCon and PatSyn: * Each argument flag is Inferred or Specified. None are Required. (A DataCon is a term-level function; see - Note [No Required TyBinder in terms] in TyCoRep.) + Note [No Required TyCoBinder in terms] in TyCoRep.) Why do we need the TyVarBinders, rather than just the TyVars? So that we can construct the right type for the DataCon with its foralls @@ -451,6 +456,26 @@ can use visible type application at a call of the data constructor. See also [DataCon user type variable binders] for an extended discussion on the order in which TyVarBinders appear in a DataCon. +Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) + => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b~(c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + + Function call 'dataConKindEqSpec' returns [k'~k] + Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ dcSourceArity does not take constraints into account, @@ -508,33 +533,35 @@ FC demands the variables go in universal-then-existential order under the hood. Our solution is thus to equip DataCon with two different sets of type variables: -* dcUnivTyVars and dcExTyVars, for the universal and existential type - variables, respectively. Their order is irrelevant for the purposes of - TypeApplications, and as a consequence, they do not come equipped with - visibilities (that is, they are TyVars instead of TyVarBinders). +* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential + type/coercion variables, respectively. Their order is irrelevant for the + purposes of TypeApplications, and as a consequence, they do not come equipped + with visibilities (that is, they are TyVars/TyCoVars instead of + TyCoVarBinders). * dcUserTyVarBinders, for the type variables binders in the order in which they - originally arose in the user-written type signature. Their order *does* - matter for TypeApplications, so they are full TyVarBinders, complete - with visibilities. + originally arose in the user-written type signature. Their order *does* matter + for TypeApplications, so they are full TyVarBinders, complete with + visibilities. This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders consists precisely of: * The set of tyvars in dcUnivTyVars whose type variables do not appear in dcEqSpec, unioned with: -* The set of tyvars in dcExTyVars - -The word "set" is used above because the order in which the tyvars -appear in dcUserTyVarBinders can be completely different from the order in -dcUnivTyVars or dcExTyVars. That is, the tyvars in dcUserTyVarBinders are a -permutation of (dcExTyVars + a subset of dcUnivTyVars). But aside from the -ordering, they in fact share the same type variables (with the same Uniques). -We sometimes refer to this as "the dcUserTyVarBinders invariant". - -dcUserTyVarBinders, as the name suggests, is the one that users will see most -of the time. It's used when computing the type signature of a data constructor -(see dataConUserType), and as a result, it's what matters from a -TypeApplications perspective. +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". + +dcUserTyVarBinders, as the name suggests, is the one that users will see most of +the time. It's used when computing the type signature of a data constructor (see +dataConUserType), and as a result, it's what matters from a TypeApplications +perspective. -} -- | Data Constructor Representation @@ -640,7 +667,7 @@ data StrictnessMark = MarkedStrict | NotMarkedStrict data EqSpec = EqSpec TyVar Type --- | Make an 'EqSpec' +-- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec mkEqSpec tv ty = EqSpec tv ty @@ -844,18 +871,18 @@ isMarkedStrict _ = True -- All others are strict -- | Build a new data constructor mkDataCon :: Name - -> Bool -- ^ Is the constructor declared infix? - -> TyConRepName -- ^ TyConRepName for the promoted TyCon - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user - -> [FieldLabel] -- ^ Field labels for the constructor, - -- if it is a record, otherwise empty - -> [TyVar] -- ^ Universals. - -> [TyVar] -- ^ Existentials. - -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. - -- These must be Inferred/Specified. - -- See @Note [TyVarBinders in DataCons]@ - -> [EqSpec] -- ^ GADT equalities - -> KnotTied ThetaType -- ^ Theta-type occuring before the arguments proper + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ + -> [EqSpec] -- ^ GADT equalities + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper -> [KnotTied Type] -- ^ Original argument types -> KnotTied Type -- ^ Original result type -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' @@ -890,7 +917,7 @@ mkDataCon name declared_infix prom_info con = MkData {dcName = name, dcUnique = nameUnique name, dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, + dcExTyCoVars = ex_tvs, dcUserTyVarBinders = user_tvbs, dcEqSpec = eq_spec, dcOtherTheta = theta, @@ -902,7 +929,7 @@ mkDataCon name declared_infix prom_info dcWorkId = work_id, dcRep = rep, dcSourceArity = length orig_arg_tys, - dcRepArity = length rep_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, dcPromoted = promoted } -- The 'arg_stricts' passed to mkDataCon are simply those for the @@ -918,13 +945,13 @@ mkDataCon name declared_infix prom_info NoDataConRep -> dataConUserType con -- If the DataCon has a wrapper, then the worker's type is never seen -- by the user. The visibilities we pick do not matter here. - DCR{} -> mkInvForAllTys univ_tvs $ mkInvForAllTys ex_tvs $ + DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ mkFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) -- See Note [Promoted data constructors] in TyCon prom_tv_bndrs = [ mkNamedTyConBinder vis tv - | TvBndr tv vis <- user_tvbs ] + | Bndr tv vis <- user_tvbs ] prom_arg_bndrs = mkCleanAnonTyConBinders prom_tv_bndrs (theta ++ orig_arg_tys) prom_res_kind = orig_res_ty @@ -932,8 +959,9 @@ mkDataCon name declared_infix prom_info (prom_tv_bndrs ++ prom_arg_bndrs) prom_res_kind roles rep_info - roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ - map (const Representational) orig_arg_tys + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) orig_arg_tys mkCleanAnonTyConBinders :: [TyConBinder] -> [Type] -> [TyConBinder] -- Make sure that the "anonymous" tyvars don't clash in @@ -1000,13 +1028,14 @@ dataConIsInfix = dcInfix dataConUnivTyVars :: DataCon -> [TyVar] dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs --- | The existentially-quantified type variables of the constructor -dataConExTyVars :: DataCon -> [TyVar] -dataConExTyVars (MkData { dcExTyVars = tvbs }) = tvbs +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs --- | Both the universal and existential type variables of the constructor -dataConUnivAndExTyVars :: DataCon -> [TyVar] -dataConUnivAndExTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs }) +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) = univ_tvs ++ ex_tvs -- See Note [DataCon user type variable binders] @@ -1015,7 +1044,7 @@ dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs -- See Note [DataCon user type variable binders] --- | 'TyVarBinder's for the type variables of the constructor, in the order the +-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the -- user wrote them dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConUserTyVarBinders = dcUserTyVarBinders @@ -1024,8 +1053,9 @@ dataConUserTyVarBinders = dcUserTyVarBinders -- by the programmer in any GADT declaration. This includes *all* GADT-like -- equalities, including those written in by hand by the programmer. dataConEqSpec :: DataCon -> [EqSpec] -dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eq_spec ++ +dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = dataConKindEqSpec con + ++ eq_spec ++ [ spec -- heterogeneous equality | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta , tc `hasKey` heqTyConKey @@ -1043,11 +1073,29 @@ dataConEqSpec (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) _ -> [] ] +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + tv = getTyVar "dataConKindEqSpec" ty1 + ] --- | The *full* constraints on the constructor type. +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. dataConTheta :: DataCon -> ThetaType -dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) - = eqSpecPreds eq_spec ++ theta +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta -- | Get the Id of the 'DataCon' worker: a function that is the "actual" -- constructor and has no top level binding in the program. The type may @@ -1057,9 +1105,11 @@ dataConWorkId :: DataCon -> Id dataConWorkId dc = dcWorkId dc -- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" --- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'. --- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor --- and also for a newtype (whose constructor is inlined compulsorily) +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) dataConWrapId_maybe :: DataCon -> Maybe Id dataConWrapId_maybe dc = case dcRep dc of NoDataConRep -> Nothing @@ -1148,54 +1198,62 @@ dataConBoxer _ = Nothing -- | The \"signature\" of the 'DataCon' returns, in order: -- --- 1) The result of 'dataConUnivAndExTyVars', +-- 1) The result of 'dataConUnivAndExTyCoVars', -- --- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, implicit --- parameter - whatever) +-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, +-- implicit parameter - whatever), including dependent GADT equalities. +-- Dependent GADT equalities are *also* listed in return value (1), so be +-- careful! -- -- 3) The type arguments to the constructor -- -- 4) The /original/ result type of the 'DataCon' -dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) +dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type) dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (dataConUnivAndExTyVars con, dataConTheta con, arg_tys, res_ty) + = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty) dataConInstSig :: DataCon -> [Type] -- Instantiate the *universal* tyvars with these types - -> ([TyVar], ThetaType, [Type]) -- Return instantiated existentials - -- theta and arg tys + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys -- ^ Instantiate the universal tyvars of a data con, --- returning the instantiated existentials, constraints, and args -dataConInstSig (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs - , dcEqSpec = eq_spec, dcOtherTheta = theta - , dcOrigArgTys = arg_tys }) +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) univ_tys = ( ex_tvs' - , substTheta subst (eqSpecPreds eq_spec ++ theta) + , substTheta subst (dataConTheta con) , substTys subst arg_tys) where univ_subst = zipTvSubst univ_tvs univ_tys - (subst, ex_tvs') = Type.substTyVarBndrs univ_subst ex_tvs + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs -- | The \"full signature\" of the 'DataCon' returns, in order: -- -- 1) The result of 'dataConUnivTyVars' -- --- 2) The result of 'dataConExTyVars' +-- 2) The result of 'dataConExTyCoVars' -- --- 3) The GADT equalities +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). -- --- 4) The result of 'dataConDictTheta' +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities -- -- 5) The original argument types to the 'DataCon' (i.e. before -- any change of the representation of the type) -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) @@ -1232,7 +1290,8 @@ dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, mkFunTys arg_tys $ res_ty --- | Finds the instantiated types of the arguments required to construct a 'DataCon' representation +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation -- NB: these INCLUDE any dictionary args -- but EXCLUDE the data-declaration context, which is discarded -- It's all post-flattening etc; this is a representation type @@ -1242,7 +1301,7 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality -> [Type] -- ^ Instantiated at these types -> [Type] dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys + dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( univ_tvs `equalLength` inst_tys , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) ASSERT2( null ex_tvs, ppr dc ) @@ -1259,19 +1318,20 @@ dataConInstOrigArgTys -- But for the call in MatchCon, we really do want just the value args dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs}) inst_tys + dcExTyCoVars = ex_tvs}) inst_tys = ASSERT2( tyvars `equalLength` inst_tys - , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) - map (substTyWith tyvars inst_tys) arg_tys + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTy subst) arg_tys where tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys -- | Returns the argument types of the wrapper, excluding all dictionary arguments -- and without substituting for any type variables dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys dc = dcOrigArgTys dc --- | Returns the arg types of the worker, including *all* +-- | Returns the arg types of the worker, including *all* non-dependent -- evidence, after any flattening has been done and without substituting for -- any type variables dataConRepArgTys :: DataCon -> [Type] @@ -1346,9 +1406,9 @@ dataConCannotMatch tys con -- Note [Data con wrappers and GADT syntax] for an explanation of what -- mkDataConRep is doing with this function. dataConUserTyVarsArePermuted :: DataCon -> Bool -dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs, - dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcUserTyVarBinders = user_tvbs }) = +dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec + , dcUserTyVarBinders = user_tvbs }) = (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs {- diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot index 61fb3ce15d..a69133463b 100644 --- a/compiler/basicTypes/DataCon.hs-boot +++ b/compiler/basicTypes/DataCon.hs-boot @@ -1,7 +1,7 @@ module DataCon where import GhcPrelude -import Var( TyVar, TyVarBinder ) +import Var( TyVar, TyCoVar, TyVarBinder ) import Name( Name, NamedThing ) import {-# SOURCE #-} TyCon( TyCon ) import FieldLabel ( FieldLabel ) @@ -16,7 +16,7 @@ data EqSpec dataConName :: DataCon -> Name dataConTyCon :: DataCon -> TyCon -dataConExTyVars :: DataCon -> [TyVar] +dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar] dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity :: DataCon -> Arity @@ -24,7 +24,7 @@ dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConStupidTheta :: DataCon -> ThetaType dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [EqSpec], ThetaType, [Type], Type) + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) isUnboxedSumCon :: DataCon -> Bool instance Eq DataCon diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 47fbce7458..5a6f1fbf96 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -394,7 +394,8 @@ mkDictSelRhs clas val_index dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys - rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) (Var dict_id) + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) + (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] -- varToCoreExpr needed for equality superclass selectors @@ -465,7 +466,7 @@ mkDataConWorkId wkr_name data_con ----------- Workers for newtypes -------------- (nt_tvs, _, nt_arg_tys, _) = dataConSig data_con - res_ty_args = mkTyVarTys nt_tvs + res_ty_args = mkTyCoVarTys nt_tvs nt_wrap_ty = dataConUserType data_con nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 @@ -484,7 +485,7 @@ dataConCPR :: DataCon -> DmdResult dataConCPR con | isDataTyCon tycon -- Real data types only; that is, -- not unboxed tuples or newtypes - , null (dataConExTyVars con) -- No existentials + , null (dataConExTyCoVars con) -- No existentials , wkr_arity > 0 , wkr_arity <= mAX_CPR_SIZE = if is_prod then vanillaCprProdRes (dataConRepArity con) @@ -631,7 +632,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con orig_bangs = dataConSrcBangs data_con wrap_arg_tys = theta ++ orig_arg_tys - wrap_arity = length wrap_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys -- The wrap_args are the arguments *other than* the eq_spec -- Because we are going to apply the eq_spec args manually in the -- wrapper @@ -672,8 +673,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con mk_boxer boxers = DCB (\ ty_args src_vars -> do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars subst1 = zipTvSubst univ_tvs ty_args - subst2 = extendTvSubstList subst1 ex_tvs - (mkTyVarTys ex_vars) + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyCoVarTys ex_vars) ; (rep_ids, binds) <- go subst2 boxers term_vars ; return (ex_vars ++ rep_ids, binds) } ) @@ -892,7 +893,8 @@ dataConArgUnpack arg_ty -- A recursive newtype might mean that -- 'arg_ty' is a newtype , let rep_tys = dataConInstArgTys con tc_args - = ASSERT( null (dataConExTyVars con) ) -- Note [Unpacking GADTs and existentials] + = ASSERT( null (dataConExTyCoVars con) ) + -- Note [Unpacking GADTs and existentials] ( rep_tys `zip` dataConRepStrictness con ,( \ arg_id -> do { rep_ids <- mapM newLocal rep_tys @@ -959,7 +961,8 @@ isUnpackableType dflags fam_envs ty unpackable_type ty | Just (tc, _) <- splitTyConApp_maybe ty , Just data_con <- tyConSingleAlgDataCon_maybe tc - , null (dataConExTyVars data_con) -- See Note [Unpacking GADTs and existentials] + , null (dataConExTyCoVars data_con) + -- See Note [Unpacking GADTs and existentials] = Just data_con | otherwise = Nothing @@ -975,7 +978,7 @@ components, like And it'd be fine to unpack a product type with existential components too, but that would require a bit more plumbing, so currently we don't. -So for now we require: null (dataConExTyVars data_con) +So for now we require: null (dataConExTyCoVars data_con) See Trac #14978 Note [Unpack one-wide fields] @@ -1136,7 +1139,7 @@ mkFCallId dflags uniq fcall ty `setLevityInfoWithType` ty (bndrs, _) = tcSplitPiTys ty - arity = count isAnonTyBinder bndrs + arity = count isAnonTyCoBinder bndrs strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes -- the call does not claim to be strict in its arguments, since they -- may be lifted (foreign import prim) and the called code doesn't diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 2e838d6b82..bf9426ecc8 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -79,7 +79,7 @@ data PatSyn -- Result type psResultTy :: Type, -- Mentions only psUnivTyVars - -- See Note [Pattern synonym result type] + -- See Note [Pattern synonym result type] -- See Note [Matchers and builders for pattern synonyms] psMatcher :: (Id, Bool), @@ -339,10 +339,10 @@ instance Data.Data PatSyn where -- | Build a new pattern synonym mkPatSyn :: Name -> Bool -- ^ Is the pattern synonym declared infix? - -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type variables - -- and required dicts - -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type variables - -- and provided dicts + -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts -> [Type] -- ^ Original arguments -> Type -- ^ Original result type -> (Id, Bool) -- ^ Name of matcher diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index afefa6eb7d..2009b6c764 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -61,10 +61,12 @@ module Var ( mustHaveLocalBinding, -- * TyVar's - TyVarBndr(..), ArgFlag(..), TyVarBinder, - binderVar, binderVars, binderArgFlag, binderKind, + VarBndr(..), ArgFlag(..), TyCoVarBinder, TyVarBinder, + binderVar, binderVars, binderArgFlag, binderType, isVisibleArgFlag, isInvisibleArgFlag, sameVis, + mkTyCoVarBinder, mkTyCoVarBinders, mkTyVarBinder, mkTyVarBinders, + isTyVarBinder, -- ** Constructing TyVar's mkTyVar, mkTcTyVar, @@ -190,7 +192,7 @@ type OutId = Id Note [Kind and type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before kind polymorphism, TyVar were used to mean type variables. Now -they are use to mean kind *or* type variables. KindVar is used when we +they are used to mean kind *or* type variables. KindVar is used when we know for sure that it is a kind variable. In future, we might want to go over the whole compiler code to use: - TKVar to mean kind or type variables @@ -380,7 +382,7 @@ updateVarTypeM f id = do { ty' <- f (varType id) -- Is something required to appear in source Haskell ('Required'), -- permitted by request ('Specified') (visible type application), or -- prohibited entirely from appearing in source Haskell ('Inferred')? --- See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] in TyCoRep +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep data ArgFlag = Inferred | Specified | Required deriving (Eq, Ord, Data) -- (<) on ArgFlag meant "is less visible than" @@ -405,45 +407,68 @@ sameVis _ _ = True {- ********************************************************************* * * -* TyVarBndr, TyVarBinder +* VarBndr, TyCoVarBinder * * ********************************************************************* -} --- Type Variable Binder +-- Variable Binder -- --- TyVarBndr is polymorphic in both tyvar and visibility fields: --- * tyvar can be TyVar or IfaceTv --- * argf can be ArgFlag or TyConBndrVis -data TyVarBndr tyvar argf = TvBndr tyvar argf +-- VarBndr is polymorphic in both var and visibility fields. +-- Currently there are six different uses of 'VarBndr': +-- * Var.TyVarBinder = VarBndr TyVar ArgFlag +-- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +-- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis +-- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +-- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +-- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +data VarBndr var argf = Bndr var argf deriving( Data ) --- | Type Variable Binder +-- | Variable Binder -- --- A 'TyVarBinder' is the binder of a ForAllTy +-- A 'TyCoVarBinder' is the binder of a ForAllTy -- It's convenient to define this synonym here rather its natural -- home in TyCoRep, because it's used in DataCon.hs-boot -type TyVarBinder = TyVarBndr TyVar ArgFlag +-- +-- A 'TyVarBinder' is a binder with only TyVar +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag -binderVar :: TyVarBndr tv argf -> tv -binderVar (TvBndr v _) = v +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v -binderVars :: [TyVarBndr tv argf] -> [tv] +binderVars :: [VarBndr tv argf] -> [tv] binderVars tvbs = map binderVar tvbs -binderArgFlag :: TyVarBndr tv argf -> argf -binderArgFlag (TvBndr _ argf) = argf +binderArgFlag :: VarBndr tv argf -> argf +binderArgFlag (Bndr _ argf) = argf + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv -binderKind :: TyVarBndr TyVar argf -> Kind -binderKind (TvBndr tv _) = tyVarKind tv +-- | Make a named binder +mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder +mkTyCoVarBinder vis var = Bndr var vis -- | Make a named binder -mkTyVarBinder :: ArgFlag -> Var -> TyVarBinder -mkTyVarBinder vis var = TvBndr var vis +-- 'var' should be a type variable +mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder +mkTyVarBinder vis var + = ASSERT( isTyVar var ) + Bndr var vis -- | Make many named binders +mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] +mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) + +-- | Make many named binders +-- Input vars should be type variables mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] mkTyVarBinders vis = map (mkTyVarBinder vis) +isTyVarBinder :: TyCoVarBinder -> Bool +isTyVarBinder (Bndr v _) = isTyVar v + {- ************************************************************************ * * @@ -500,20 +525,20 @@ setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar setTcTyVarDetails tv details = tv { tc_tv_details = details } ------------------------------------- -instance Outputable tv => Outputable (TyVarBndr tv ArgFlag) where - ppr (TvBndr v Required) = ppr v - ppr (TvBndr v Specified) = char '@' <> ppr v - ppr (TvBndr v Inferred) = braces (ppr v) +instance Outputable tv => Outputable (VarBndr tv ArgFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) instance Outputable ArgFlag where ppr Required = text "[req]" ppr Specified = text "[spec]" ppr Inferred = text "[infrd]" -instance (Binary tv, Binary vis) => Binary (TyVarBndr tv vis) where - put_ bh (TvBndr tv vis) = do { put_ bh tv; put_ bh vis } +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } - get bh = do { tv <- get bh; vis <- get bh; return (TvBndr tv vis) } + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } instance Binary ArgFlag where diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs index 5f934e0fbb..d15da87aac 100644 --- a/compiler/coreSyn/CoreArity.hs +++ b/compiler/coreSyn/CoreArity.hs @@ -1037,10 +1037,19 @@ mkEtaWW orig_n orig_expr in_scope orig_ty | n == 0 = (getTCvInScope subst, reverse eis) - | Just (tv,ty') <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substTyVarBndr subst tv + | Just (tcv,ty') <- splitForAllTy_maybe ty + , let (subst', tcv') = Type.substVarBndr subst tcv + = let ((n_subst, n_tcv), n_n) + -- We want to have at least 'n' lambdas at the top. + -- If tcv is a tyvar, it corresponds to one Lambda (/\). + -- And we won't reduce n. + -- If tcv is a covar, we could eta-expand the expr with one + -- lambda \co:ty. e co. In this case we generate a new variable + -- of the coercion type, update the scope, and reduce n by 1. + | isTyVar tcv = ((subst', tcv'), n) + | otherwise = (freshEtaId n subst' (varType tcv'), n-1) -- Avoid free vars of the original expression - = go n subst' ty' (EtaVar tv' : eis) + in go n_n n_subst ty' (EtaVar n_tcv : eis) | Just (arg_ty, res_ty) <- splitFunTy_maybe ty , not (isTypeLevPoly arg_ty) @@ -1123,8 +1132,8 @@ etaBodyForJoinPoint need_args body = (reverse rev_bs, e) go n ty subst rev_bs e | Just (tv, res_ty) <- splitForAllTy_maybe ty - , let (subst', tv') = Type.substTyVarBndr subst tv - = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` Type (mkTyVarTy tv')) + , let (subst', tv') = Type.substVarBndr subst tv + = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') | Just (arg_ty, res_ty) <- splitFunTy_maybe ty , let (subst', b) = freshEtaId n subst arg_ty = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 607fb73bbe..bc54d26ad3 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -351,7 +351,7 @@ orphNamesOfType (TyVarTy _) = emptyNameSet orphNamesOfType (LitTy {}) = emptyNameSet orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon `unionNameSet` orphNamesOfTypes tys -orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderKind bndr) +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) `unionNameSet` orphNamesOfType res orphNamesOfType (FunTy arg res) = unitNameSet funTyConName -- NB! See Trac #8535 `unionNameSet` orphNamesOfType arg diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 349d36d8e2..21edba1241 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1352,9 +1352,10 @@ lintType ty@(FunTy t1 t2) ; k2 <- lintType t2 ; lintArrow (text "type or kind" <+> quotes (ppr ty)) k1 k2 } -lintType t@(ForAllTy (TvBndr tv _vis) ty) - = do { lintL (isTyVar tv) (text "Covar bound in type:" <+> ppr t) - ; lintTyBndr tv $ \tv' -> +lintType t@(ForAllTy (Bndr tv _vis) ty) + -- forall over types + | isTyVar tv + = do { lintTyBndr tv $ \tv' -> do { k <- lintType ty ; checkValueKind k (text "the body of forall:" <+> ppr t) ; case occCheckExpand [tv'] k of -- See Note [Stupid type synonyms] @@ -1364,6 +1365,20 @@ lintType t@(ForAllTy (TvBndr tv _vis) ty) , text "kind:" <+> ppr k ])) }} +lintType t@(ForAllTy (Bndr cv _vis) ty) + -- forall over coercions + = do { lintL (isCoVar cv) + (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr t) + ; lintL (cv `elemVarSet` tyCoVarsOfType ty) + (text "Covar does not occur in the body:" <+> ppr t) + ; lintCoBndr cv $ \_ -> + do { k <- lintType ty + ; checkValueKind k (text "the body of forall:" <+> ppr t) + ; return liftedTypeKind + -- We don't check variable escape here. Namely, k could refer to cv' + -- See Note [NthCo and newtypes] in TyCoRep + }} + lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty) lintType (CastTy ty co) @@ -1491,11 +1506,11 @@ lint_app doc kfn kas addErrL (fail_msg (text "Fun:" <+> (ppr kfa $$ ppr tka))) ; return kfb } - go_app in_scope (ForAllTy (TvBndr kv _vis) kfn) tka@(ta,ka) - = do { let kv_kind = tyVarKind kv + go_app in_scope (ForAllTy (Bndr kv _vis) kfn) tka@(ta,ka) + = do { let kv_kind = varType kv ; unless (ka `eqType` kv_kind) $ addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$ ppr tka))) - ; return (substTyWithInScope in_scope [kv] [ta] kfn) } + ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn } go_app _ kfn ka = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ka))) @@ -1681,6 +1696,8 @@ lintCoercion co@(AppCo co1 co2) ---------- lintCoercion (ForAllCo tv1 kind_co co) + -- forall over types + | isTyVar tv1 = do { (_, k2) <- lintStarCoercion kind_co ; let tv2 = setTyVarKind tv1 k2 ; addInScopeVar tv1 $ @@ -1700,6 +1717,37 @@ lintCoercion (ForAllCo tv1 kind_co co) substTy subst t2 ; return (k3, k4, tyl, tyr, r) } } +lintCoercion (ForAllCo cv1 kind_co co) + -- forall over coercions + = ASSERT( isCoVar cv1 ) + do { (_, k2) <- lintStarCoercion kind_co + ; let cv2 = setVarType cv1 k2 + ; addInScopeVar cv1 $ + do { + ; (k3, k4, t1, t2, r) <- lintCoercion co + ; checkValueKind k3 (text "the body of a ForAllCo over covar:" <+> ppr co) + ; checkValueKind k4 (text "the body of a ForAllCo over covar:" <+> ppr co) + -- See Note [Weird typing rule for ForAllTy] in Type + ; in_scope <- getInScope + ; let tyl = mkTyCoInvForAllTy cv1 t1 + r2 = coVarRole cv1 + kind_co' = downgradeRole r2 Nominal kind_co + eta1 = mkNthCo r2 2 kind_co' + eta2 = mkNthCo r2 3 kind_co' + subst = mkCvSubst in_scope $ + -- We need both the free vars of the `t2` and the + -- free vars of the range of the substitution in + -- scope. All the free vars of `t2` and `kind_co` should + -- already be in `in_scope`, because they've been + -- linted and `cv2` has the same unique as `cv1`. + -- See Note [The substitution invariant] + unitVarEnv cv1 (eta1 `mkTransCo` (mkCoVarCo cv2) + `mkTransCo` (mkSymCo eta2)) + tyr = mkTyCoInvForAllTy cv2 $ + substTy subst t2 + ; return (liftedTypeKind, liftedTypeKind, tyl, tyr, r) } } + -- See Note [Weird typing rule for ForAllTy] in Type + lintCoercion co@(FunCo r co1 co2) = do { (k1,k'1,s1,t1,r1) <- lintCoercion co1 ; (k2,k'2,s2,t2,r2) <- lintCoercion co2 @@ -1804,13 +1852,16 @@ lintCoercion co@(TransCo co1 co2) lintCoercion the_co@(NthCo r0 n co) = do { (_, _, s, t, r) <- lintCoercion co ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of - { (Just (tv_s, _ty_s), Just (tv_t, _ty_t)) - | n == 0 + { (Just (tcv_s, _ty_s), Just (tcv_t, _ty_t)) + -- works for both tyvar and covar + | n == 0 + , (isForAllTy_ty s && isForAllTy_ty t) + || (isForAllTy_co s && isForAllTy_co t) -> do { lintRole the_co Nominal r0 ; return (ks, kt, ts, tt, r0) } where - ts = tyVarKind tv_s - tt = tyVarKind tv_t + ts = varType tcv_s + tt = varType tcv_t ks = typeKind ts kt = typeKind tt @@ -1853,16 +1904,32 @@ lintCoercion (InstCo co arg) ; (k1',k2',s1,s2, r') <- lintCoercion arg ; lintRole arg Nominal r' ; in_scope <- getInScope - ; case (splitForAllTy_maybe t1', splitForAllTy_maybe t2') of - (Just (tv1,t1), Just (tv2,t2)) - | k1' `eqType` tyVarKind tv1 - , k2' `eqType` tyVarKind tv2 - -> return (k3, k4, - substTyWithInScope in_scope [tv1] [s1] t1, - substTyWithInScope in_scope [tv2] [s2] t2, r) - | otherwise - -> failWithL (text "Kind mis-match in inst coercion") - _ -> failWithL (text "Bad argument of inst") } + ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of + -- forall over tvar + { (Just (tv1,t1), Just (tv2,t2)) + | k1' `eqType` tyVarKind tv1 + , k2' `eqType` tyVarKind tv2 + -> return (k3, k4, + substTyWithInScope in_scope [tv1] [s1] t1, + substTyWithInScope in_scope [tv2] [s2] t2, r) + | otherwise + -> failWithL (text "Kind mis-match in inst coercion") + ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of + -- forall over covar + { (Just (cv1, t1), Just (cv2, t2)) + | k1' `eqType` varType cv1 + , k2' `eqType` varType cv2 + , CoercionTy s1' <- s1 + , CoercionTy s2' <- s2 + -> do { return $ + (liftedTypeKind, liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in Type + , substTy (mkCvSubst in_scope $ unitVarEnv cv1 s1') t1 + , substTy (mkCvSubst in_scope $ unitVarEnv cv2 s2') t2 + , r) } + | otherwise + -> failWithL (text "Kind mis-match in inst coercion") + ; _ -> failWithL (text "Bad argument of inst") }}} lintCoercion co@(AxiomInstCo con ind cos) = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) diff --git a/compiler/coreSyn/CoreMap.hs b/compiler/coreSyn/CoreMap.hs index 0c9faa3efe..11f2fb1b11 100644 --- a/compiler/coreSyn/CoreMap.hs +++ b/compiler/coreSyn/CoreMap.hs @@ -522,8 +522,8 @@ instance Eq (DeBruijn Type) where -> tc == tc' && D env tys == D env' tys' (LitTy l, LitTy l') -> l == l' - (ForAllTy (TvBndr tv _) ty, ForAllTy (TvBndr tv' _) ty') - -> D env (tyVarKind tv) == D env' (tyVarKind tv') && + (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') + -> D env (varType tv) == D env' (varType tv') && D (extendCME env tv) ty == D (extendCME env' tv') ty' (CoercionTy {}, CoercionTy {}) -> True @@ -563,7 +563,7 @@ lkT (D env ty) m = go ty m go (TyConApp tc []) = tm_tycon >.> lkDNamed tc go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) go (LitTy l) = tm_tylit >.> lkTyLit l - go (ForAllTy (TvBndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) >=> lkBndr env tv go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) go (CastTy t _) = go t @@ -580,7 +580,7 @@ xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } xtT (D env (CastTy t _)) f m = xtT (D env t) f m xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } -xtT (D env (ForAllTy (TvBndr tv _) ty)) f m +xtT (D env (ForAllTy (Bndr tv _) ty)) f m = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) |>> xtBndr env tv f } xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs index 3254d7334c..2367c4548d 100644 --- a/compiler/coreSyn/CoreOpt.hs +++ b/compiler/coreSyn/CoreOpt.hs @@ -1010,8 +1010,8 @@ pushCoTyArg co ty | isReflCo co = Just (ty, MRefl) - | isForAllTy tyL - = ASSERT2( isForAllTy tyR, ppr co $$ ppr ty ) + | isForAllTy_ty tyL + = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) Just (ty `mkCastTy` co1, MCo co2) | otherwise @@ -1112,11 +1112,11 @@ pushCoDataCon dc dc_args co = let tc_arity = tyConArity to_tc dc_univ_tyvars = dataConUnivTyVars dc - dc_ex_tyvars = dataConExTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc arg_tys = dataConRepArgTys dc non_univ_args = dropList dc_univ_tyvars dc_args - (ex_args, val_args) = splitAtList dc_ex_tyvars non_univ_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args -- Make the "Psi" from the paper omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) @@ -1124,7 +1124,7 @@ pushCoDataCon dc dc_args co = liftCoSubstWithEx Representational dc_univ_tyvars omegas - dc_ex_tyvars + dc_ex_tcvars (map exprToType ex_args) -- Cast the value arguments (which include dictionaries) @@ -1133,7 +1133,7 @@ pushCoDataCon dc dc_args co to_ex_args = map Type to_ex_arg_tys - dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, ppr arg_tys, ppr dc_args, ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] in @@ -1179,11 +1179,19 @@ collectBindersPushingCo e go_lam bs b e co | isTyVar b , let Pair tyL tyR = coercionKind co - , ASSERT( isForAllTy tyL ) - isForAllTy tyR + , ASSERT( isForAllTy_ty tyL ) + isForAllTy_ty tyR , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + | isCoVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_co tyL ) + isForAllTy_co tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + , let cov = mkCoVarCo b + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + | isId b , let Pair tyL tyR = coercionKind co , ASSERT( isFunTy tyL) isFunTy tyR diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs index 3d2b4b1a10..2df3fb1b52 100644 --- a/compiler/coreSyn/CoreSubst.hs +++ b/compiler/coreSyn/CoreSubst.hs @@ -89,7 +89,7 @@ data Subst TvSubstEnv -- Substitution from TyVars to Types CvSubstEnv -- Substitution from CoVars to Coercions - -- INVARIANT 1: See TyCORep Note [The substitution invariant] + -- INVARIANT 1: See TyCoRep Note [The substitution invariant] -- This is what lets us deal with name capture properly -- It's a hard invariant to check... -- @@ -171,7 +171,7 @@ mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs --- | Find the in-scope set: see TyCORep Note [The substitution invariant] +-- | Find the in-scope set: see TyCoRep Note [The substitution invariant] substInScope :: Subst -> InScopeSet substInScope (Subst in_scope _ _ _) = in_scope @@ -181,7 +181,7 @@ zapSubstEnv :: Subst -> Subst zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is --- such that TyCORep Note [The substitution invariant] +-- such that TyCoRep Note [The substitution invariant] -- holds after extending the substitution like this extendIdSubst :: Subst -> Id -> CoreExpr -> Subst -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set @@ -198,7 +198,7 @@ extendIdSubstList (Subst in_scope ids tvs cvs) prs -- | Add a substitution for a 'TyVar' to the 'Subst' -- The 'TyVar' *must* be a real TyVar, and not a CoVar -- You must ensure that the in-scope set is such that --- TyCORep Note [The substitution invariant] holds +-- TyCoRep Note [The substitution invariant] holds -- after extending the substitution like this. extendTvSubst :: Subst -> TyVar -> Type -> Subst extendTvSubst (Subst in_scope ids tvs cvs) tv ty @@ -214,7 +214,7 @@ extendTvSubstList subst vrs -- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': -- you must ensure that the in-scope set satisfies --- TyCORep Note [The substitution invariant] +-- TyCoRep Note [The substitution invariant] -- after extending the substitution like this extendCvSubst :: Subst -> CoVar -> Coercion -> Subst extendCvSubst (Subst in_scope ids tvs cvs) v r diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs index 5c2a44f909..be5e6c1619 100644 --- a/compiler/coreSyn/CoreTidy.hs +++ b/compiler/coreSyn/CoreTidy.hs @@ -22,7 +22,7 @@ import CoreArity import Id import IdInfo import Demand ( zapUsageEnvSig ) -import Type( tidyType, tidyTyCoVarBndr ) +import Type( tidyType, tidyVarBndr ) import Coercion( tidyCo ) import Var import VarEnv @@ -130,7 +130,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyCoVar var = tidyTyCoVarBndr env var + | isTyCoVar var = tidyVarBndr env var | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 7635a6d66a..a1dae9875e 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -77,7 +77,7 @@ import Id import IdInfo import PrelNames( absentErrorIdKey ) import Type -import TyCoRep( TyBinder(..) ) +import TyCoRep( TyCoBinder(..), TyBinder ) import Coercion import TyCon import Unique @@ -1879,8 +1879,8 @@ exprIsTickedString_maybe _ = Nothing These InstPat functions go here to avoid circularity between DataCon and Id -} -dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) dataConRepFSInstPat = dataConInstPat @@ -1889,7 +1889,7 @@ dataConInstPat :: [FastString] -- A long enough list of FSs to use for -> [Unique] -- An equally long list of uniques, at least one for each binder -> DataCon -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [Id]) -- Return instantiated variables + -> ([TyCoVar], [Id]) -- Return instantiated variables -- dataConInstPat arg_fun fss us con inst_tys returns a tuple -- (ex_tvs, arg_ids), -- @@ -1922,7 +1922,7 @@ dataConInstPat fss uniqs con inst_tys (ex_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con - ex_tvs = dataConExTyVars con + ex_tvs = dataConExTyCoVars con arg_tys = dataConRepArgTys con arg_strs = dataConRepStrictness con -- 1-1 with arg_tys n_ex = length ex_tvs @@ -1938,13 +1938,16 @@ dataConInstPat fss uniqs con inst_tys (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst (zip3 ex_tvs ex_fss ex_uniqs) - mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar) - mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubstWithClone subst tv + mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv new_tv , new_tv) where - new_tv = mkTyVar (mkSysTvName uniq fs) kind - kind = Type.substTyUnchecked subst (tyVarKind tv) + new_tv | isTyVar tv + = mkTyVar (mkSysTvName uniq fs) kind + | otherwise + = mkCoVar (mkSystemVarName uniq fs) kind + kind = Type.substTyUnchecked subst (varType tv) -- Make value vars, instantiating types arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs diff --git a/compiler/deSugar/DsForeign.hs b/compiler/deSugar/DsForeign.hs index fdece6ee6a..5856ff2445 100644 --- a/compiler/deSugar/DsForeign.hs +++ b/compiler/deSugar/DsForeign.hs @@ -203,7 +203,7 @@ dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header dsFCall fn_id co fcall mDeclHeader = do let ty = pFst $ coercionKind co - (tv_bndrs, rho) = tcSplitForAllTyVarBndrs ty + (tv_bndrs, rho) = tcSplitForAllVarBndrs ty (arg_tys, io_res_ty) = tcSplitFunTys rho args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 49586bc972..af542340fa 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -120,7 +120,10 @@ matchOneConLike :: [Id] -> [EquationInfo] -> DsM (CaseAlt ConLike) matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor - = do { let inst_tys = ASSERT( tvs1 `equalLength` ex_tvs ) + = do { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs ) + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018). + ASSERT( tvs1 `equalLength` ex_tvs ) arg_tys ++ mkTyVarTys tvs1 val_arg_tys = conLikeInstOrigArgTys con1 inst_tys @@ -169,7 +172,7 @@ matchOneConLike vars ty (eqn1 : eqns) -- All eqns for a single constructor = firstPat eqn1 fields1 = map flSelector (conLikeFieldLabels con1) - ex_tvs = conLikeExTyVars con1 + ex_tvs = conLikeExTyCoVars con1 -- Choose the right arg_vars in the right order for this group -- Note [Record patterns] diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index e2c76c49af..18feeb523f 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -712,7 +712,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- MutVar# :: contents_ty -> MutVar# s contents_ty traceTR (text "Following a MutVar") contents_tv <- newVar liftedTypeKind - ASSERT(isUnliftedType my_ty) return () + MASSERT(isUnliftedType my_ty) (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy contents_ty (mkTyConApp tycon [world,contents_ty]) addConstraint (mkFunTy contents_tv my_ty) mutvar_ty @@ -1002,6 +1002,9 @@ getDataConArgTys dc con_app_ty = do { let rep_con_app_ty = unwrapType con_app_ty ; traceTR (text "getDataConArgTys 1" <+> (ppr con_app_ty $$ ppr rep_con_app_ty $$ ppr (tcSplitTyConApp_maybe rep_con_app_ty))) + ; ASSERT( all isTyVar ex_tvs ) return () + -- ex_tvs can only be tyvars as data types in source + -- Haskell cannot mention covar yet (Aug 2018) ; (subst, _) <- instTyVars (univ_tvs ++ ex_tvs) ; addConstraint rep_con_app_ty (substTy subst (dataConOrigResTy dc)) -- See Note [Constructor arg types] @@ -1010,7 +1013,7 @@ getDataConArgTys dc con_app_ty ; return con_arg_tys } where univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyVars dc + ex_tvs = dataConExTyCoVars dc {- Note [Constructor arg types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 3ddd355a6d..693e2899c8 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -101,7 +101,7 @@ buildDataCon :: FamInstEnvs -- See Note [Bangs on imported data constructors] in MkId -> [FieldLabel] -- Field labels -> [TyVar] -- Universals - -> [TyVar] -- Existentials + -> [TyCoVar] -- Existentials -> [TyVarBinder] -- User-written 'TyVarBinder's -> [EqSpec] -- Equality spec -> KnotTied ThetaType -- Does not include the "stupid theta" diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 2784dda795..3266c5aec1 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -64,7 +64,7 @@ import SrcLoc import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) -import Var( TyVarBndr(..) ) +import Var( VarBndr(..) ) import TyCon ( Role (..), Injectivity(..) ) import Util( dropList, filterByList ) import DataCon (SrcStrictness(..), SrcUnpackedness(..)) @@ -243,13 +243,13 @@ data IfaceConDecl -- but it's not so easy for the original TyCon/DataCon -- So this guarantee holds for IfaceConDecl, but *not* for DataCon - ifConExTvs :: [IfaceTvBndr], -- Existential tyvars + 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 ifConExTvs, unioned with the set of ifBinders - -- (from the parent IfaceDecl) whose tyvars do not appear - -- in ifConEqSpec + -- 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 @@ -1062,8 +1062,11 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent ppr_tc_app gadt_subst dflags = pprPrefixIfDeclBndr how_much (occName tycon) <+> sep [ pprParendIfaceType (substIfaceTyVar gadt_subst tv) - | (tv,_kind) - <- map ifTyConBinderTyVar $ + | IfaceTvBndr (tv,_kind) + -- Coercions variables are invisible, see Note + -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + -- in TyCoRep + <- map (ifTyConBinderVar) $ suppressIfaceInvisibles dflags tc_binders tc_binders ] instance Outputable IfaceRule where @@ -1290,7 +1293,7 @@ freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k , ifParent = p, ifCtxt = ctxt, ifCons = cons }) - = freeNamesIfTyVarBndrs bndrs &&& + = freeNamesIfVarBndrs bndrs &&& freeNamesIfType res_k &&& freeNamesIfaceTyConParent p &&& freeNamesIfContext ctxt &&& @@ -1298,18 +1301,18 @@ freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k , ifSynRhs = rhs }) - = freeNamesIfTyVarBndrs bndrs &&& + = freeNamesIfVarBndrs bndrs &&& freeNamesIfKind res_k &&& freeNamesIfType rhs freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k , ifFamFlav = flav }) - = freeNamesIfTyVarBndrs bndrs &&& + = freeNamesIfVarBndrs bndrs &&& freeNamesIfKind res_k &&& freeNamesIfFamFlav flav freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) - = freeNamesIfTyVarBndrs bndrs &&& + = freeNamesIfVarBndrs bndrs &&& freeNamesIfClassBody cls_body freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) @@ -1327,8 +1330,8 @@ freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) , ifFieldLabels = lbls }) = unitNameSet matcher &&& maybe emptyNameSet (unitNameSet . fst) mb_builder &&& - freeNamesIfTyVarBndrs univ_bndrs &&& - freeNamesIfTyVarBndrs ex_bndrs &&& + freeNamesIfVarBndrs univ_bndrs &&& + freeNamesIfVarBndrs ex_bndrs &&& freeNamesIfContext prov_ctxt &&& freeNamesIfContext req_ctxt &&& fnList freeNamesIfType args &&& @@ -1391,12 +1394,12 @@ freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl (IfCon { ifConExTvs = ex_tvs, ifConCtxt = ctxt +freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt , ifConArgTys = arg_tys , ifConFields = flds , ifConEqSpec = eq_spec , ifConStricts = bangs }) - = fnList freeNamesIfTvBndr ex_tvs &&& + = fnList freeNamesIfBndr ex_tvs &&& freeNamesIfContext ctxt &&& fnList freeNamesIfType arg_tys &&& mkNameSet (map flSelector flds) &&& @@ -1422,7 +1425,7 @@ freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts freeNamesIfType (IfaceLitTy _) = emptyNameSet -freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTyVarBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceDFunTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c @@ -1475,11 +1478,11 @@ freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _) = emptyNameSet -freeNamesIfTyVarBndr :: TyVarBndr IfaceTvBndr vis -> NameSet -freeNamesIfTyVarBndr (TvBndr tv _) = freeNamesIfTvBndr tv +freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet +freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr -freeNamesIfTyVarBndrs :: [TyVarBndr IfaceTvBndr vis] -> NameSet -freeNamesIfTyVarBndrs = fnList freeNamesIfTyVarBndr +freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet +freeNamesIfVarBndrs = fnList freeNamesIfVarBndr freeNamesIfBndr :: IfaceBndr -> NameSet freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index 06ea8ff8db..23b09dab7a 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -22,8 +22,8 @@ module IfaceType ( IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, IfaceForAllBndr, ArgFlag(..), ShowForAllFlag(..), - ifForAllBndrTyVar, ifForAllBndrName, - ifTyConBinderTyVar, ifTyConBinderName, + ifForAllBndrVar, ifForAllBndrName, + ifTyConBinderVar, ifTyConBinderName, -- Equality testing isIfaceLiftedTypeKind, @@ -96,6 +96,13 @@ 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 + type IfaceLamBndr = (IfaceBndr, IfaceOneShot) data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy @@ -148,8 +155,8 @@ data IfaceTyLit | IfaceStrTyLit FastString deriving (Eq) -type IfaceTyConBinder = TyVarBndr IfaceTvBndr TyConBndrVis -type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag +type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag -- See Note [Suppressing invisible arguments] -- We use a new list type (rather than [(IfaceType,Bool)], because @@ -297,7 +304,7 @@ data IfaceCoercion | IfaceFunCo Role IfaceCoercion IfaceCoercion | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceAppCo IfaceCoercion IfaceCoercion - | IfaceForAllCo IfaceTvBndr IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion | IfaceCoVarCo IfLclName | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] | IfaceAxiomRuleCo IfLclName [IfaceCoercion] @@ -398,21 +405,21 @@ stripIfaceInvisVars dflags tyvars | gopt Opt_PrintExplicitKinds dflags = tyvars | otherwise = filterOut isInvisibleTyConBinder tyvars --- | Extract an 'IfaceTvBndr' from an 'IfaceForAllBndr'. -ifForAllBndrTyVar :: IfaceForAllBndr -> IfaceTvBndr -ifForAllBndrTyVar = binderVar +-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. +ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr +ifForAllBndrVar = binderVar -- | Extract the variable name from an 'IfaceForAllBndr'. ifForAllBndrName :: IfaceForAllBndr -> IfLclName -ifForAllBndrName fab = ifaceTvBndrName (ifForAllBndrTyVar fab) +ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) --- | Extract an 'IfaceTvBndr' from an 'IfaceTyConBinder'. -ifTyConBinderTyVar :: IfaceTyConBinder -> IfaceTvBndr -ifTyConBinderTyVar = binderVar +-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. +ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr +ifTyConBinderVar = binderVar -- | Extract the variable name from an 'IfaceTyConBinder'. ifTyConBinderName :: IfaceTyConBinder -> IfLclName -ifTyConBinderName tcb = ifaceTvBndrName (ifTyConBinderTyVar tcb) +ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) ifTypeIsVarFree :: IfaceType -> Bool -- Returns True if the type definitely has no variables at all @@ -532,8 +539,8 @@ stripInvisArgs dflags tys IA_Vis t ts -> IA_Vis t $ 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 [TyVarBndrs, - -- TyVarBinders, TyConBinders, and visibility] in TyCoRep. + -- See the "In type declarations" section of Note [VarBndrs, + -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] appArgsIfaceTypes IA_Nil = [] @@ -660,9 +667,10 @@ pprIfaceTvBndr use_parens (tv, ki) | otherwise = id pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc -pprIfaceTyConBinders = sep . map go +pprIfaceTyConBinders = sep . map (go . ifTyConBinderVar) where - go tcb = pprIfaceTvBndr True (ifTyConBinderTyVar tcb) + go (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + go (IfaceTvBndr bndr) = pprIfaceTvBndr True bndr instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do @@ -756,7 +764,7 @@ ppr_ty ctxt_prec (IfaceCoercionTy co) (ppr_co ctxt_prec co) (text "<>") -ppr_ty ctxt_prec ty +ppr_ty ctxt_prec ty -- IfaceForAllTy = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) {- @@ -804,18 +812,15 @@ defaultRuntimeRepVars :: PprStyle -> IfaceType -> IfaceType defaultRuntimeRepVars sty = go emptyFsEnv where go :: FastStringEnv () -> IfaceType -> IfaceType - go subs (IfaceForAllTy bndr ty) + go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) | isRuntimeRep var_kind - , isInvisibleArgFlag (binderArgFlag bndr) -- don't default *visible* quantification - -- or we get the mess in #13963 + , isInvisibleArgFlag argf -- don't default *visible* quantification + -- or we get the mess in #13963 = let subs' = extendFsEnv subs var () in go subs' ty - | otherwise - = IfaceForAllTy (TvBndr (var, go subs var_kind) (binderArgFlag bndr)) - (go subs ty) - where - var :: IfLclName - (var, var_kind) = binderVar bndr + + go subs (IfaceForAllTy bndr ty) + = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty) go subs ty@(IfaceTyVar tv) | tv `elemFsEnv` subs @@ -851,6 +856,12 @@ defaultRuntimeRepVars sty = go emptyFsEnv 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 subs t)) argf + go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) + = Bndr (IfaceTvBndr (n, go subs t)) argf + go_args :: FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs go_args _ IA_Nil = IA_Nil go_args subs (IA_Vis ty args) = IA_Vis (go subs ty) (go_args subs args) @@ -917,7 +928,7 @@ ppr_iface_forall_part show_forall tvs ctxt sdoc -- | Render the "forall ... ." or "forall ... ->" bit of a type. pprIfaceForAll :: [IfaceForAllBndr] -> SDoc pprIfaceForAll [] = empty -pprIfaceForAll bndrs@(TvBndr _ vis : _) +pprIfaceForAll bndrs@(Bndr _ vis : _) = add_separator (forAllLit <+> doc) <+> pprIfaceForAll bndrs' where (bndrs', doc) = ppr_itv_bndrs bndrs vis @@ -933,7 +944,7 @@ pprIfaceForAll bndrs@(TvBndr _ vis : _) ppr_itv_bndrs :: [IfaceForAllBndr] -> ArgFlag -- ^ visibility of the first binder in the list -> ([IfaceForAllBndr], SDoc) -ppr_itv_bndrs all_bndrs@(bndr@(TvBndr _ vis) : bndrs) vis1 +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, empty) @@ -947,11 +958,13 @@ pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc -pprIfaceForAllBndr (TvBndr tv Inferred) = sdocWithDynFlags $ \dflags -> - if gopt Opt_PrintExplicitForalls dflags - then braces $ pprIfaceTvBndr False tv - else pprIfaceTvBndr True tv -pprIfaceForAllBndr (TvBndr tv _) = pprIfaceTvBndr True tv +pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) Inferred) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitForalls dflags + then braces $ pprIfaceTvBndr False tv + else pprIfaceTvBndr True tv +pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) _) = pprIfaceTvBndr True tv +pprIfaceForAllBndr (Bndr (IfaceIdBndr idv) _) = pprIfaceIdBndr idv pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc pprIfaceForAllCoBndr (tv, kind_co) @@ -981,7 +994,10 @@ pprUserIfaceForAll tvs || gopt Opt_PrintExplicitForalls dflags) $ pprIfaceForAll tvs where - tv_has_kind_var (TvBndr (_,kind) _) = not (ifTypeIsVarFree kind) + tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) + = not (ifTypeIsVarFree kind) + tv_has_kind_var _ = False + tv_is_required = isVisibleArgFlag . binderArgFlag {- @@ -1012,8 +1028,10 @@ criteria are met: because omitting it and printing "T :: k -> Type" would be utterly misleading. - See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] + See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. + +N.B. Until now (Aug 2018) we didn't check anything for coercion variables. -} ------------------- @@ -1108,7 +1126,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style -- of eqTyCon (~) -- eqPrimTyCon (~#) -- eqReprPrimTyCon (~R#) --- hEqTyCon (~~) +-- heqTyCon (~~) -- -- See Note [Equality predicates in IfaceType] -- and Note [The equality types story] in TysPrim @@ -1280,7 +1298,9 @@ ppr_co ctxt_prec co@(IfaceForAllCo {}) where (tvs, inner_co) = split_co co - split_co (IfaceForAllCo (name, _) kind_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') diff --git a/compiler/iface/IfaceType.hs-boot b/compiler/iface/IfaceType.hs-boot index 200e96c69d..44f1f3cfc2 100644 --- a/compiler/iface/IfaceType.hs-boot +++ b/compiler/iface/IfaceType.hs-boot @@ -3,16 +3,13 @@ module IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where -import Var (TyVarBndr, ArgFlag) -import FastString (FastString) +import Var (VarBndr, ArgFlag) data IfaceAppArgs -type IfLclName = FastString -type IfaceKind = IfaceType data IfaceType data IfaceTyCon data IfaceTyLit data IfaceCoercion -type IfaceTvBndr = (IfLclName, IfaceKind) -type IfaceForAllBndr = TyVarBndr IfaceTvBndr ArgFlag +data IfaceBndr +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 59a396e381..4d2fa83f86 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1646,7 +1646,7 @@ coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs , ifaxbRHS = tidyToIfaceType env1 rhs , ifaxbIncomps = [] } where - (env1, tidy_tvs) = tidyTyCoVarBndrs emptyTidyEnv tvs + (env1, tidy_tvs) = tidyVarBndrs emptyTidyEnv tvs -- Don't re-bind in-scope tyvars -- See Note [CoAxBranch type variables] in CoAxiom @@ -1710,7 +1710,7 @@ tyConToIfaceDecl env tycon -- an error. (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon) tc_tyvars = binderVars tc_binders - if_binders = toIfaceTyVarBinders tc_binders + if_binders = toIfaceTyCoVarBinders tc_binders if_res_kind = tidyToIfaceType tc_env1 (tyConResKind tycon) if_syn_type ty = tidyToIfaceType tc_env1 ty if_res_var = getOccFS `fmap` tyConFamilyResVar_maybe tycon @@ -1751,7 +1751,7 @@ tyConToIfaceDecl env tycon = IfCon { ifConName = dataConName data_con, ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConExTvs = map toIfaceTvBndr ex_tvs', + ifConExTCvs = map toIfaceBndr ex_tvs', ifConUserTvBinders = map toIfaceForAllBndr user_bndrs', ifConEqSpec = map (to_eq_spec . eqSpecPair) eq_spec, ifConCtxt = tidyToIfaceContext con_env2 theta, @@ -1776,27 +1776,27 @@ tyConToIfaceDecl env tycon con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars)) -- A bit grimy, perhaps, but it's simple! - (con_env2, ex_tvs') = tidyTyCoVarBndrs con_env1 ex_tvs - user_bndrs' = map (tidyUserTyVarBinder con_env2) user_bndrs + (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 dcUserTyVarBinders invariant + -- 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 tidyTyVarOcc accomplishes. - tidyUserTyVarBinder :: TidyEnv -> TyVarBinder -> TyVarBinder - tidyUserTyVarBinder env (TvBndr tv vis) = - TvBndr (tidyTyVarOcc env tv) vis + -- 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 = toIfaceTyVarBinders tc_binders, + ifBinders = toIfaceTyCoVarBinders tc_binders, ifBody = body, ifFDs = map toIfaceFD clas_fds }) where @@ -1848,10 +1848,10 @@ 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@(TvBndr tv vis) +tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis) = case lookupVarEnv subst tv of - Just tv' -> (env, TvBndr tv' vis) - Nothing -> tidyTyVarBinder env tvb + Just tv' -> (env, Bndr tv' vis) + Nothing -> tidyTyCoVarBinder env tvb tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder]) tidyTyConBinders = mapAccumL tidyTyConBinder diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 0dc3fb5381..248f7d3c38 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -861,7 +861,7 @@ tc_ax_branch prev_branches , ifaxbLHS = lhs, ifaxbRHS = rhs , ifaxbRoles = roles, ifaxbIncomps = incomps }) = bindIfaceTyConBinders_AT - (map (\b -> TvBndr b (NamedTCB Inferred)) tv_bndrs) $ \ tvs -> + (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 @@ -891,7 +891,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons tag_map = mkTyConTagMap tycon tc_con_decl (IfCon { ifConInfix = is_infix, - ifConExTvs = ex_bndrs, + ifConExTCvs = ex_bndrs, ifConUserTvBinders = user_bndrs, ifConName = dc_name, ifConCtxt = ctxt, ifConEqSpec = spec, @@ -900,7 +900,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons ifConSrcStricts = if_src_stricts}) = -- Universally-quantified tyvars are shared with -- parent TyCon, and are already in scope - bindIfaceTyVars ex_bndrs $ \ ex_tvs -> do + 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 @@ -909,8 +909,12 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons -- 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 (\(TvBndr (name, _) vis) -> - TvBndr <$> tcIfaceTyVar name <*> pure vis) + ; 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 @@ -936,7 +940,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons -- Remember, tycon is the representation tycon ; let orig_res_ty = mkFamilyTyConApp tycon - (substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) + (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec)) (binderVars tc_tybinders)) ; prom_rep_name <- newTyConRepName dc_name @@ -1145,7 +1149,7 @@ tcIfaceType = go ; return (mkTyConApp tc' tks') } go (IfaceForAllTy bndr t) = bindIfaceForAllBndr bndr $ \ tv' vis -> - ForAllTy (TvBndr tv' vis) <$> go t + ForAllTy (Bndr tv' vis) <$> go t go (IfaceCastTy ty co) = CastTy <$> go ty <*> tcIfaceCo co go (IfaceCoercionTy co) = CoercionTy <$> tcIfaceCo co @@ -1211,7 +1215,7 @@ tcIfaceCo = go = 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 - ; bindIfaceTyVar tv $ \ tv' -> + ; 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 @@ -1745,23 +1749,18 @@ bindIfaceBndrs (b:bs) thing_inside thing_inside (b':bs') ----------------------- -bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyVarBinder] -> IfL a) -> IfL a +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 (mkTyVarBinder vis tv : bndrs') + thing_inside (mkTyCoVarBinder vis tv : bndrs') -bindIfaceForAllBndr :: IfaceForAllBndr -> (TyVar -> ArgFlag -> IfL a) -> IfL a -bindIfaceForAllBndr (TvBndr tv vis) thing_inside +bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a +bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis - -bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a -bindIfaceTyVars [] thing_inside = thing_inside [] -bindIfaceTyVars (tv:tvs) thing_inside - = bindIfaceTyVar tv $ \tv' -> - bindIfaceTyVars tvs $ \tvs' -> - thing_inside (tv' : tvs') +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 @@ -1778,8 +1777,8 @@ bindIfaceTyConBinders :: [IfaceTyConBinder] -> ([TyConBinder] -> IfL a) -> IfL a bindIfaceTyConBinders [] thing_inside = thing_inside [] bindIfaceTyConBinders (b:bs) thing_inside - = bindIfaceTyConBinderX bindIfaceTyVar b $ \ b' -> - bindIfaceTyConBinders bs $ \ bs' -> + = bindIfaceTyConBinderX bindIfaceBndr b $ \ b' -> + bindIfaceTyConBinders bs $ \ bs' -> thing_inside (b':bs') bindIfaceTyConBinders_AT :: [IfaceTyConBinder] @@ -1796,14 +1795,14 @@ bindIfaceTyConBinders_AT (b : bs) thing_inside thing_inside (b':bs') where bind_tv tv thing - = do { mb_tv <- lookupIfaceTyVar tv + = do { mb_tv <- lookupIfaceVar tv ; case mb_tv of Just b' -> thing b' - Nothing -> bindIfaceTyVar tv thing } + Nothing -> bindIfaceBndr tv thing } -bindIfaceTyConBinderX :: (IfaceTvBndr -> (TyVar -> IfL a) -> IfL a) +bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a) -> IfaceTyConBinder -> (TyConBinder -> IfL a) -> IfL a -bindIfaceTyConBinderX bind_tv (TvBndr tv vis) thing_inside +bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside = bind_tv tv $ \tv' -> - thing_inside (TvBndr tv' vis) + thing_inside (Bndr tv' vis) diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs index 0b0782d6e8..653b7407da 100644 --- a/compiler/iface/ToIface.hs +++ b/compiler/iface/ToIface.hs @@ -8,7 +8,7 @@ module ToIface , toIfaceIdBndr , toIfaceBndr , toIfaceForAllBndr - , toIfaceTyVarBinders + , toIfaceTyCoVarBinders , toIfaceTyVar -- * Types , toIfaceType, toIfaceTypeX @@ -81,23 +81,32 @@ toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) , toIfaceTypeX fr (tyVarKind tyvar) ) - -toIfaceIdBndr :: Id -> (IfLclName, IfaceType) -toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) - 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) -toIfaceTyVarBinder :: TyVarBndr TyVar vis -> TyVarBndr IfaceTvBndr vis -toIfaceTyVarBinder (TvBndr tv vis) = TvBndr (toIfaceTvBndr tv) vis +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 -toIfaceTyVarBinders :: [TyVarBndr TyVar vis] -> [TyVarBndr IfaceTvBndr vis] -toIfaceTyVarBinders = map toIfaceTyVarBinder +toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] +toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder {- ************************************************************************ @@ -168,11 +177,11 @@ toIfaceTyVar = occNameFS . getOccName toIfaceCoVar :: CoVar -> FastString toIfaceCoVar = occNameFS . getOccName -toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet -toIfaceForAllBndrX :: VarSet -> TyVarBinder -> IfaceForAllBndr -toIfaceForAllBndrX fr (TvBndr v vis) = TvBndr (toIfaceTvBndrX fr v) vis +toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon @@ -256,7 +265,7 @@ toIfaceCoercionX fr 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 (toIfaceTvBndr tv) + go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) (toIfaceCoercionX fr' k) (toIfaceCoercionX fr' co) where @@ -295,12 +304,12 @@ toIfaceAppArgsX fr kind ty_args go env ty ts | Just ty' <- coreView ty = go env ty' ts - go env (ForAllTy (TvBndr tv vis) res) (t:ts) + go env (ForAllTy (Bndr tv vis) res) (t:ts) | isVisibleArgFlag vis = IA_Vis t' ts' | otherwise = IA_Invis t' ts' where t' = toIfaceTypeX fr t - ts' = go (extendTvSubst env tv t) res ts + ts' = go (extendTCvSubst env tv t) res ts go env (FunTy _ res) (t:ts) -- No type-class args in tycon apps = IA_Vis (toIfaceTypeX fr t) (go env res ts) @@ -354,8 +363,8 @@ patSynToIfaceDecl ps (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps univ_bndrs = patSynUnivTyVarBinders ps ex_bndrs = patSynExTyVarBinders ps - (env1, univ_bndrs') = tidyTyVarBinders emptyTidyEnv univ_bndrs - (env2, ex_bndrs') = tidyTyVarBinders env1 ex_bndrs + (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs to_if_pr (id, needs_dummy) = (idName id, needs_dummy) {- diff --git a/compiler/iface/ToIface.hs-boot b/compiler/iface/ToIface.hs-boot index 46083f0414..e5f57ff9a3 100644 --- a/compiler/iface/ToIface.hs-boot +++ b/compiler/iface/ToIface.hs-boot @@ -3,14 +3,14 @@ module ToIface where import {-# SOURCE #-} TyCoRep import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) -import Var ( TyVarBinder ) +import Var ( TyCoVarBinder ) import TyCon ( TyCon ) import VarSet( VarSet ) -- For TyCoRep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit -toIfaceForAllBndr :: TyVarBinder -> IfaceForAllBndr +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index 30dca25eea..c5af4a5121 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -96,7 +96,7 @@ import {-# SOURCE #-} TysWiredIn , doubleElemRepDataConTy , mkPromotedListTy ) -import Var ( TyVar, TyVarBndr(TvBndr), mkTyVar ) +import Var ( TyVar, VarBndr(Bndr), mkTyVar ) import Name import TyCon import SrcLoc @@ -351,8 +351,8 @@ funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon funTyCon :: TyCon funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm where - tc_bndrs = [ TvBndr runtimeRep1TyVar (NamedTCB Inferred) - , TvBndr runtimeRep2TyVar (NamedTCB Inferred) + tc_bndrs = [ Bndr runtimeRep1TyVar (NamedTCB Inferred) + , Bndr runtimeRep2TyVar (NamedTCB Inferred) ] ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty , tYPE runtimeRep2Ty @@ -598,7 +598,7 @@ GHC sports a veritable menagerie of equality types: class? L/U TyCon ----------------------------------------------------------------------------------------- ~# T U hetero nominal eqPrimTyCon GHC.Prim -~~ C L hetero nominal hEqTyCon GHC.Types +~~ C L hetero nominal heqTyCon GHC.Types ~ C L homo nominal eqTyCon GHC.Types :~: T L homo nominal (not built-in) Data.Type.Equality :~~: T L hetero nominal (not built-in) Data.Type.Equality diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 740d0d772d..1d47185f02 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -486,8 +486,8 @@ pcDataCon n univs = pcDataConWithFixity False n univs pcDataConWithFixity :: Bool -- ^ declared infix? -> Name -- ^ datacon name -> [TyVar] -- ^ univ tyvars - -> [TyVar] -- ^ ex tyvars - -> [TyVar] -- ^ user-written tyvars + -> [TyCoVar] -- ^ ex tycovars + -> [TyCoVar] -- ^ user-written tycovars -> [Type] -- ^ args -> TyCon -> DataCon @@ -501,7 +501,7 @@ pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (n -- one DataCon unique per pair of Ints. pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo - -> [TyVar] -> [TyVar] -> [TyVar] + -> [TyVar] -> [TyCoVar] -> [TyCoVar] -> [Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself. @@ -521,7 +521,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key rri (map (const no_bang) arg_tys) [] -- No labelled fields tyvars ex_tyvars - (mkTyVarBinders Specified user_tyvars) + (mkTyCoVarBinders Specified user_tyvars) [] -- No equality spec [] -- No theta arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) @@ -585,7 +585,7 @@ constraintKind = mkTyConApp constraintKindTyCon [] mkFunKind :: Kind -> Kind -> Kind mkFunKind = mkFunTy -mkForAllKind :: TyVar -> ArgFlag -> Kind -> Kind +mkForAllKind :: TyCoVar -> ArgFlag -> Kind -> Kind mkForAllKind = mkForAllTy {- diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 0d57860941..f6d27ccba5 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -38,7 +38,6 @@ import TyCon ( tyConName ) import Id import PprCore ( pprParendExpr ) import MkCore ( mkImpossibleExpr ) -import Var import VarEnv import VarSet import Name diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 4e854fc8c8..4f380d37a8 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -58,7 +58,7 @@ import MkId( mkDictFunId ) import CoreSyn( Expr(..) ) -- For the Coercion constructor import Id import Name -import Var ( EvVar, mkTyVar, tyVarName, TyVarBndr(..) ) +import Var ( EvVar, mkTyVar, tyVarName, VarBndr(..) ) import DataCon import VarEnv import PrelNames @@ -223,7 +223,7 @@ top_instantiate inst_all orig ty | otherwise = return (idHsWrapper, ty) where - (binders, phi) = tcSplitForAllTyVarBndrs ty + (binders, phi) = tcSplitForAllVarBndrs ty (theta, rho) = tcSplitPhiTy phi should_inst bndr @@ -499,7 +499,7 @@ tcInstTyBinders subst mb_kind_info bndrs -- | Used only in *types* tcInstTyBinder :: Maybe (VarEnv Kind) -> TCvSubst -> TyBinder -> TcM (TCvSubst, TcType) -tcInstTyBinder mb_kind_info subst (Named (TvBndr tv _)) +tcInstTyBinder mb_kind_info subst (Named (Bndr tv _)) = case lookup_tv tv of Just ki -> return (extendTvSubstAndInScope subst tv ki, ki) Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 3ff54dff5c..6579556843 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -995,8 +995,8 @@ can_eq_nc_forall :: CtEvidence -> EqRel can_eq_nc_forall ev eq_rel s1 s2 | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev = do { let free_tvs = tyCoVarsOfTypes [s1,s2] - (bndrs1, phi1) = tcSplitForAllTyVarBndrs s1 - (bndrs2, phi2) = tcSplitForAllTyVarBndrs s2 + (bndrs1, phi1) = tcSplitForAllVarBndrs s1 + (bndrs2, phi2) = tcSplitForAllVarBndrs s2 ; if not (equalLength bndrs1 bndrs2) then do { traceTcS "Forall failure" $ vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2 diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 87b853f42e..6827a58f55 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -408,7 +408,7 @@ reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope where tcl_env = implicLclEnv implic insoluble = isInsolubleStatus status - (env1, tvs') = mapAccumL tidyTyCoVarBndr (cec_tidy ctxt) tvs + (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs info' = tidySkolemInfo env1 info implic' = implic { ic_skols = tvs' , ic_given = map (tidyEvVar env1) given @@ -1644,7 +1644,7 @@ mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 extra3 = relevant_bindings $ ppWhen (not (null interesting_tyvars)) $ hang (text "Type variable kinds:") 2 $ - vcat (map (tyvar_binding . tidyTyVarOcc (cec_tidy ctxt)) + vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt)) interesting_tyvars) tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv) diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 4129b87aaa..5c9bdd96be 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -1153,7 +1153,7 @@ flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. {-# INLINE flatten_args #-} -flatten_args :: [TyBinder] -> Bool -- Binders, and True iff any of them are +flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are -- named. -> Kind -> TcTyCoVarSet -- function kind; kind's free vars -> [Role] -> [Type] -- these are in 1-to-1 correspondence @@ -1186,7 +1186,7 @@ flatten_args orig_binders -- There are many bang patterns in here. It's been observed that they -- greatly improve performance of an optimized build. -- The T9872 test cases are good witnesses of this fact. -flatten_args_fast :: [TyBinder] +flatten_args_fast :: [TyCoBinder] -> Kind -> [Role] -> [Type] @@ -1197,8 +1197,8 @@ flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys iterate :: [Type] -> [Role] - -> [TyBinder] - -> FlatM ([Xi], [Coercion], [TyBinder]) + -> [TyCoBinder] + -> FlatM ([Xi], [Coercion], [TyCoBinder]) iterate (ty:tys) (role:roles) (_:binders) = do (xi, co) <- go role ty (xis, cos, binders) <- iterate tys roles binders @@ -1233,7 +1233,7 @@ flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys -- mkCastTy x (Refl _ _) = x -- mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co -- - -- Also, no need to check isAnonTyBinder or isNamedTyBinder, since + -- Also, no need to check isAnonTyCoBinder or isNamedTyCoBinder, since -- we've already established that they're all anonymous. Nominal -> setEqRel NomEq $ flatten_one ty Representational -> setEqRel ReprEq $ flatten_one ty @@ -1243,7 +1243,7 @@ flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys {-# INLINE finish #-} - finish :: ([Xi], [Coercion], [TyBinder]) -> ([Xi], [Coercion], CoercionN) + finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN) finish (xis, cos, binders) = (xis, cos, kind_co) where final_kind = mkPiTys binders orig_inner_ki @@ -1252,7 +1252,7 @@ flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys {-# INLINE flatten_args_slow #-} -- | Slow path, compared to flatten_args_fast, because this one must track -- a lifting context. -flatten_args_slow :: [TyBinder] -> Kind -> TcTyCoVarSet +flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet -> [Role] -> [Type] -> FlatM ([Xi], [Coercion], CoercionN) flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys @@ -1264,7 +1264,7 @@ flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys -> [Coercion] -- Coercions accumulator, in reverse order -- These are in 1-to-1 correspondence -> LiftingContext -- mapping from tyvars to flattening coercions - -> [TyBinder] -- Unsubsted binders of function's kind + -> [TyCoBinder] -- Unsubsted binders of function's kind -> Kind -- Unsubsted result kind of function (not a Pi-type) -> [Role] -- Roles at which to flatten these ... -> [Type] -- ... unflattened types @@ -1272,21 +1272,21 @@ flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys go acc_xis acc_cos lc binders inner_ki _ [] = return (reverse acc_xis, reverse acc_cos, kind_co) where - final_kind = mkPiTys binders inner_ki + final_kind = mkTyCoPiTys binders inner_ki kind_co = liftCoSubst Nominal lc final_kind go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) (ty:tys) = do { (xi, co) <- case role of Nominal -> setEqRel NomEq $ - if isNamedTyBinder binder + if isNamedTyCoBinder binder then noBogusCoercions $ flatten_one ty else flatten_one ty - Representational -> ASSERT( isAnonTyBinder binder ) + Representational -> ASSERT( isAnonTyCoBinder binder ) setEqRel ReprEq $ flatten_one ty Phantom -> -- See Note [Phantoms in the flattener] - ASSERT( isAnonTyBinder binder ) + ASSERT( isAnonTyCoBinder binder ) do { ty <- liftTcS $ zonkTcType ty ; return (ty, mkReflCo Phantom ty) } @@ -1299,12 +1299,12 @@ flatten_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys -- The bangs here have been observed to improve performance -- significantly in optimized builds. ; let kind_co = mkTcSymCo $ - liftCoSubst Nominal lc (tyBinderType binder) + liftCoSubst Nominal lc (tyCoBinderType binder) !casted_xi = xi `mkCastTy` kind_co casted_co = mkTcCoherenceLeftCo role xi kind_co co -- now, extend the lifting context with the new binding - !new_lc | Just tv <- tyBinderVar_maybe binder + !new_lc | Just tv <- tyCoBinderVar_maybe binder = extendLiftingContextAndInScope lc tv casted_co | otherwise = lc @@ -1421,7 +1421,7 @@ flatten_one ty@(ForAllTy {}) -- We allow for-alls when, but only when, no type function -- applications inside the forall involve the bound type variables. - = do { let (bndrs, rho) = tcSplitForAllTyVarBndrs ty + = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty tvs = binderVars bndrs ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho -- Substitute only under a forall @@ -2160,7 +2160,7 @@ Flatten using the fun-eqs first. -- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at -- least one named binder. -split_pi_tys' :: Type -> ([TyBinder], Type, Bool) +split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) split_pi_tys' ty = split ty ty where split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' @@ -2171,14 +2171,14 @@ split_pi_tys' ty = split ty ty split orig_ty _ = ([], orig_ty, False) {-# INLINE split_pi_tys' #-} --- | Like 'tyConBindersTyBinders' but you also get a 'Bool' which is true iff +-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff -- there is at least one named binder. -ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyBinder], Bool) +ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) ty_con_binders_ty_binders' = foldr go ([], False) where - go (TvBndr tv (NamedTCB vis)) (bndrs, _) - = (Named (TvBndr tv vis) : bndrs, True) - go (TvBndr tv AnonTCB) (bndrs, n) + go (Bndr tv (NamedTCB vis)) (bndrs, _) + = (Named (Bndr tv vis) : bndrs, True) + go (Bndr tv AnonTCB) (bndrs, n) = (Anon (tyVarKind tv) : bndrs, n) {-# INLINE go #-} {-# INLINE ty_con_binders_ty_binders' #-} diff --git a/compiler/typecheck/TcForeign.hs b/compiler/typecheck/TcForeign.hs index f7ec465026..8038de3d84 100644 --- a/compiler/typecheck/TcForeign.hs +++ b/compiler/typecheck/TcForeign.hs @@ -131,7 +131,7 @@ normaliseFfiType' env ty0 = go initRecTc ty0 | Just (tc, tys) <- splitTyConApp_maybe ty = go_tc_app rec_nts tc tys - | (bndrs, inner_ty) <- splitForAllTyVarBndrs ty + | (bndrs, inner_ty) <- splitForAllVarBndrs ty , not (null bndrs) = do (coi, nty1, gres1) <- go rec_nts inner_ty return ( mkHomoForAllCos (binderVars bndrs) coi diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index 8310cf9500..41d8eb858a 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -392,7 +392,7 @@ functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar -- variables in a unboxed tuple pattern match and expression as it -- actually needs. See Trac #12399 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args)) - go co (ForAllTy (TvBndr v vis) x) + go co (ForAllTy (Bndr v vis) x) | isVisibleArgFlag vis = panic "unexpected visible binder" | v /= var && xc = (caseForAll v xr,True) where (xr,xc) = go co x diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index e2567c6af6..3363aa2be0 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -429,20 +429,20 @@ zonkTyBndrX env tv ; let tv' = mkTyVar (tyVarName tv) ki ; return (extendTyZonkEnv1 env tv', tv') } -zonkTyVarBinders :: [TyVarBndr TcTyVar vis] - -> TcM (ZonkEnv, [TyVarBndr TyVar vis]) +zonkTyVarBinders :: [VarBndr TcTyVar vis] + -> TcM (ZonkEnv, [VarBndr TyVar vis]) zonkTyVarBinders = initZonkEnv zonkTyVarBindersX -zonkTyVarBindersX :: ZonkEnv -> [TyVarBndr TcTyVar vis] - -> TcM (ZonkEnv, [TyVarBndr TyVar vis]) +zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis] + -> TcM (ZonkEnv, [VarBndr TyVar vis]) zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX -zonkTyVarBinderX :: ZonkEnv -> TyVarBndr TcTyVar vis - -> TcM (ZonkEnv, TyVarBndr TyVar vis) +zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis + -> TcM (ZonkEnv, VarBndr TyVar vis) -- Takes a TcTyVar and guarantees to return a TyVar -zonkTyVarBinderX env (TvBndr tv vis) +zonkTyVarBinderX env (Bndr tv vis) = do { (env', tv') <- zonkTyBndrX env tv - ; return (env', TvBndr tv' vis) } + ; return (env', Bndr tv' vis) } zonkTopExpr :: HsExpr GhcTcId -> TcM (HsExpr GhcTc) zonkTopExpr e = initZonkEnv zonkExpr e @@ -1814,7 +1814,7 @@ zonk_tycomapper = TyCoMapper , tcm_tyvar = zonkTyVarOcc , tcm_covar = zonkCoVarOcc , tcm_hole = zonkCoHole - , tcm_tybinder = \env tv _vis -> zonkTyBndrX env tv + , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv , tcm_tycon = zonkTcTyConToTyCon } -- Zonk a TyCon by changing a TcTyCon to a regular TyCon diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 6370626bdd..a9d6d46344 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -73,7 +73,7 @@ import TcHsSyn import TcErrors ( reportAllUnsolved ) import TcType import Inst ( tcInstTyBinders, tcInstTyBinder ) -import TyCoRep( TyBinder(..) ) -- Used in tcDataKindSig +import TyCoRep( TyCoBinder(..), TyBinder ) -- Used in tcDataKindSig import Type import Coercion import RdrName( lookupLocalRdrOcc ) @@ -1348,7 +1348,7 @@ Here and T :: forall {k3} k1. forall k3 -> k1 -> k2 -> k3 -> * -See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] +See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. kcLHsQTyVars uses the hsq_dependent field to decide whether @@ -2187,15 +2187,15 @@ tcDataKindSig tc_bndrs kind arg' = substTy subst arg tv = mkTyVar (mkInternalName uniq occ loc) arg' subst' = extendTCvInScope subst tv - tcb = TvBndr tv AnonTCB + tcb = Bndr tv AnonTCB (uniq:uniqs') = uniqs (occ:occs') = occs - Just (Named (TvBndr tv vis), kind') + Just (Named (Bndr tv vis), kind') -> go loc occs uniqs subst' (tcb : acc) kind' where (subst', tv') = substTyVarBndr subst tv - tcb = TvBndr tv' (NamedTCB vis) + tcb = Bndr tv' (NamedTCB vis) badKindSig :: Bool -> Kind -> SDoc badKindSig check_for_type kind @@ -2585,7 +2585,7 @@ zonkPromoteMapper = TyCoMapper { tcm_smart = True , tcm_tyvar = const zonkPromoteTcTyVar , tcm_covar = const covar , tcm_hole = const hole - , tcm_tybinder = const tybinder + , tcm_tycobinder = const tybinder , tcm_tycon = return } where covar cv @@ -2737,7 +2737,7 @@ reportFloatingKvs tycon_name flav all_tvs bad_tvs do { all_tvs <- mapM zonkTcTyVarToTyVar all_tvs ; bad_tvs <- mapM zonkTcTyVarToTyVar bad_tvs ; let (tidy_env, tidy_all_tvs) = tidyOpenTyCoVars emptyTidyEnv all_tvs - tidy_bad_tvs = map (tidyTyVarOcc tidy_env) bad_tvs + tidy_bad_tvs = map (tidyTyCoVarOcc tidy_env) bad_tvs ; mapM_ (report tidy_all_tvs) tidy_bad_tvs } where report tidy_all_tvs tidy_bad_tv diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs index 642a16abbb..26d1a33486 100644 --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -1542,7 +1542,7 @@ zonkTcTypeMapper = TyCoMapper , tcm_tyvar = const zonkTcTyVar , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv) , tcm_hole = hole - , tcm_tybinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv + , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTcTyCoVarBndr tv , tcm_tycon = return } where hole :: () -> CoercionHole -> TcM Coercion @@ -1580,10 +1580,10 @@ zonkTcTyCoVarBndr tyvar = ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTyVar tyvar ) updateTyVarKindM zonkTcType tyvar -zonkTcTyVarBinder :: TyVarBndr TcTyVar vis -> TcM (TyVarBndr TcTyVar vis) -zonkTcTyVarBinder (TvBndr tv vis) +zonkTcTyVarBinder :: VarBndr TcTyVar vis -> TcM (VarBndr TcTyVar vis) +zonkTcTyVarBinder (Bndr tv vis) = do { tv' <- zonkTcTyCoVarBndr tv - ; return (TvBndr tv' vis) } + ; return (Bndr tv' vis) } zonkTcTyVar :: TcTyVar -> TcM TcType -- Simply look through all Flexis @@ -1731,11 +1731,11 @@ tidySigSkol :: TidyEnv -> UserTypeCtxt tidySigSkol env cx ty tv_prs = SigSkol cx (tidy_ty env ty) tv_prs' where - tv_prs' = mapSnd (tidyTyVarOcc env) tv_prs + tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs inst_env = mkNameEnv tv_prs' - tidy_ty env (ForAllTy (TvBndr tv vis) ty) - = ForAllTy (TvBndr tv' vis) (tidy_ty env' ty) + tidy_ty env (ForAllTy (Bndr tv vis) ty) + = ForAllTy (Bndr tv' vis) (tidy_ty env' ty) where (env', tv') = tidy_tv_bndr env tv @@ -1744,13 +1744,13 @@ tidySigSkol env cx ty tv_prs tidy_ty env ty = tidyType env ty - tidy_tv_bndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) + tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) tidy_tv_bndr env@(occ_env, subst) tv | Just tv' <- lookupNameEnv inst_env (tyVarName tv) = ((occ_env, extendVarEnv subst tv tv'), tv') | otherwise - = tidyTyCoVarBndr env tv + = tidyVarBndr env tv ------------------------------------------------------------------------- {- diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 5ec71d14c5..d10829f075 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -17,7 +17,7 @@ import GhcPrelude import HsSyn import TcPat -import Type( mkEmptyTCvSubst, tidyTyVarBinders, tidyTypes, tidyType ) +import Type( mkEmptyTCvSubst, tidyTyCoVarBinders, tidyTypes, tidyType ) import TcRnMonad import TcSigs( emptyPragEnv, completeSigFromId ) import TcType( mkMinimalBySCs ) @@ -618,8 +618,8 @@ tc_patsyn_finish lname dir is_infix lpat' ; pat_ty' <- zonkTcTypeToTypeX ze pat_ty ; arg_tys' <- zonkTcTypesToTypesX ze arg_tys - ; let (env1, univ_tvs) = tidyTyVarBinders emptyTidyEnv univ_tvs' - (env2, ex_tvs) = tidyTyVarBinders env1 ex_tvs' + ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs' + (env2, ex_tvs) = tidyTyCoVarBinders env1 ex_tvs' req_theta = tidyTypes env2 req_theta' prov_theta = tidyTypes env2 prov_theta' arg_tys = tidyTypes env2 arg_tys' diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index bdcb5b1269..147c16bba3 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -1563,7 +1563,7 @@ data TcPatSynInfo patsig_name :: Name, patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and -- implicitly-bound type vars (Specified) - -- See Note [The pattern-synonym signature splitting rule] in TcSigs + -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall patsig_req :: TcThetaType, patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 21eb8292d5..c26ba0d90b 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1527,7 +1527,9 @@ reifyDataCon isGadtDataCon tys dc return $ TH.NormalC name (dcdBangs `zip` r_arg_tys) ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta) - | otherwise = (ex_tvs, theta) + | otherwise = ASSERT( all isTyVar ex_tvs ) + -- no covars for haskell syntax + (ex_tvs, theta) ret_con | null ex_tvs' && null theta' = return main_con | otherwise = do { cxt <- reifyCxt theta' diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 9fdc069dc6..eafb5b37af 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -3284,7 +3284,7 @@ checkValidDependency binders res_kind tcb_var = binderVar tcb tcb_kind = tyVarKind tcb_var - pp_binder binder = ppr (binderVar binder) <+> dcolon <+> ppr (binderKind binder) + pp_binder binder = ppr (binderVar binder) <+> dcolon <+> ppr (binderType binder) {- ************************************************************************ @@ -3401,7 +3401,7 @@ checkValidRoles tc = check_ty_roles env role ty1 >> check_ty_roles env role ty2 - check_ty_roles env role (ForAllTy (TvBndr tv _) ty) + check_ty_roles env role (ForAllTy (Bndr tv _) ty) = check_ty_roles env Nominal (tyVarKind tv) >> check_ty_roles (extendVarEnv env tv Nominal) role ty @@ -3517,7 +3517,8 @@ noClassTyVarErr clas fam_tc badDataConTyCon :: DataCon -> Type -> Type -> SDoc badDataConTyCon data_con res_ty_tmpl actual_res_ty - | tcIsForAllTy actual_res_ty + | ASSERT( all isTyVar actual_ex_tvs ) + tcIsForAllTy actual_res_ty = nested_foralls_contexts_suggestion | isJust (tcSplitPredFunTy_maybe actual_res_ty) = nested_foralls_contexts_suggestion @@ -3555,7 +3556,7 @@ badDataConTyCon data_con res_ty_tmpl actual_res_ty -- underneath the nested foralls and contexts. -- 3) Smash together the type variables and class predicates from 1) and -- 2), and prepend them to the rho type from 2). - actual_ex_tvs = dataConExTyVars data_con + actual_ex_tvs = dataConExTyCoVars data_con actual_theta = dataConTheta data_con (actual_res_tvs, actual_res_theta, actual_res_rho) = tcSplitNestedSigmaTys actual_res_ty diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs index 77608e747a..e6cd0731e5 100644 --- a/compiler/typecheck/TcType.hs +++ b/compiler/typecheck/TcType.hs @@ -40,7 +40,7 @@ module TcType ( TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, MetaDetails(Flexi, Indirect), MetaInfo(..), isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, - isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, + tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, isFskTyVar, isFmvTyVar, isFlattenTyVar, isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, isFlexi, isIndirect, isRuntimeUnkSkol, @@ -59,7 +59,7 @@ module TcType ( -- These are important because they do not look through newtypes getTyVar, tcSplitForAllTy_maybe, - tcSplitForAllTys, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBndrs, + tcSplitForAllTys, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs, tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, tcSplitFunTysN, @@ -131,13 +131,14 @@ module TcType ( -------------------------------- -- Rexported from Type - Type, PredType, ThetaType, TyBinder, ArgFlag(..), + Type, PredType, ThetaType, TyCoBinder, ArgFlag(..), - mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, mkInvForAllTy, + mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, + mkInvForAllTy, mkInvForAllTys, mkFunTy, mkFunTys, mkTyConApp, mkAppTy, mkAppTys, - mkTyConTy, mkTyVarTy, - mkTyVarTys, + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, isClassPred, isEqPred, isNomEqPred, isIPPred, mkClassPred, @@ -179,7 +180,7 @@ module TcType ( pprKind, pprParendKind, pprSigmaType, pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, - pprTvBndr, pprTvBndrs, + pprTCvBndr, pprTCvBndrs, TypeSize, sizeType, sizeTypes, toposortTyVars, @@ -338,8 +339,8 @@ type TcTyCoVar = Var -- Either a TcTyVar or a CoVar -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a -type TcTyVarBinder = TyVarBinder -type TcTyCon = TyCon -- these can be the TcTyCon constructor +type TcTyVarBinder = TyVarBinder +type TcTyCon = TyCon -- these can be the TcTyCon constructor -- These types do not have boxy type variables in them type TcPredType = PredType @@ -867,7 +868,7 @@ tcTyFamInsts (TyConApp tc tys) | isTypeFamilyTyCon tc = [(tc, take (tyConArity tc) tys)] | otherwise = concat (map tcTyFamInsts tys) tcTyFamInsts (LitTy {}) = [] -tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderKind bndr) +tcTyFamInsts (ForAllTy bndr ty) = tcTyFamInsts (binderType bndr) ++ tcTyFamInsts ty tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2 @@ -927,7 +928,7 @@ exactTyCoVarsOfType ty go (LitTy {}) = emptyVarSet go (AppTy fun arg) = go fun `unionVarSet` go arg go (FunTy arg res) = go arg `unionVarSet` go res - go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderKind bndr) + go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) go (CastTy ty co) = go ty `unionVarSet` goCo co go (CoercionTy co) = goCo co @@ -1147,7 +1148,7 @@ split_dvs bound dvs ty kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv)) , dv_tvs = tvs `extendDVarSet` tv } - go dv (ForAllTy (TvBndr tv _) ty) + go dv (ForAllTy (Bndr tv _) ty) = DV { dv_kvs = kvs `unionDVarSet` kill_bound (tyCoVarsOfTypeDSet (tyVarKind tv)) , dv_tvs = tvs } @@ -1350,18 +1351,18 @@ findDupTyVarTvs prs ************************************************************************ -} -mkSigmaTy :: [TyVarBinder] -> [PredType] -> Type -> Type +mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) -- | Make a sigma ty where all type variables are 'Inferred'. That is, -- they cannot be used with visible type application. -mkInfSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyVarBinders Inferred tyvars) theta ty +mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type +mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty -- | Make a sigma ty where all type variables are "specified". That is, -- they can be used with visible type application mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type -mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyVarBinders Specified tyvars) preds ty +mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty mkPhiTy :: [PredType] -> Type -> Type mkPhiTy = mkFunTys @@ -1408,7 +1409,7 @@ then consider the type If we call typeKind on that, we'll crash, because the (un-zonked) kind of 'a' is just kappa, not an arrow kind. If we zonk first we'd be fine, but that is too tiresome, so instead we maintain -(TK-INV). So we do not form (a Int); instead we form +(INV-TK). So we do not form (a Int); instead we form (a |> co) Int and typeKind has no problem with that. @@ -1476,11 +1477,11 @@ nakedSubstTy subst ty nakedSubstMapper :: TyCoMapper TCvSubst Identity nakedSubstMapper - = TyCoMapper { tcm_smart = False - , tcm_tyvar = \subst tv -> return (substTyVar subst tv) - , tcm_covar = \subst cv -> return (substCoVar subst cv) - , tcm_hole = \_ hole -> return (HoleCo hole) - , tcm_tybinder = \subst tv _ -> return (substTyVarBndr subst tv) + = TyCoMapper { tcm_smart = False + , tcm_tyvar = \subst tv -> return (substTyVar subst tv) + , tcm_covar = \subst cv -> return (substCoVar subst cv) + , tcm_hole = \_ hole -> return (HoleCo hole) + , tcm_tycobinder = \subst tv _ -> return (substVarBndr subst tv) , tcm_tycon = return } {- @@ -1500,25 +1501,31 @@ variables. It's up to you to make sure this doesn't matter. -- | Splits a forall type into a list of 'TyBinder's and the inner type. -- Always succeeds, even if it returns an empty list. tcSplitPiTys :: Type -> ([TyBinder], Type) -tcSplitPiTys = splitPiTys +tcSplitPiTys ty = ASSERT( all isTyBinder (fst sty) ) sty + where sty = splitPiTys ty -- | Splits a type into a TyBinder and a body, if possible. Panics otherwise tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) -tcSplitPiTy_maybe = splitPiTy_maybe +tcSplitPiTy_maybe ty = ASSERT( isMaybeTyBinder sty ) sty + where sty = splitPiTy_maybe ty + isMaybeTyBinder (Just (t,_)) = isTyBinder t + isMaybeTyBinder _ = True tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' -tcSplitForAllTy_maybe (ForAllTy tv ty) = Just (tv, ty) +tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty) tcSplitForAllTy_maybe _ = Nothing -- | Like 'tcSplitPiTys', but splits off only named binders, returning -- just the tycovars. tcSplitForAllTys :: Type -> ([TyVar], Type) -tcSplitForAllTys = splitForAllTys +tcSplitForAllTys ty = ASSERT( all isTyVar (fst sty) ) sty + where sty = splitForAllTys ty -- | Like 'tcSplitForAllTys', but splits off only named binders. -tcSplitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type) -tcSplitForAllTyVarBndrs = splitForAllTyVarBndrs +tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type) +tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty + where sty = splitForAllVarBndrs ty -- | Is this a ForAllTy with a named binder? tcIsForAllTy :: Type -> Bool @@ -1664,7 +1671,7 @@ tcSplitFunTy_maybe _ = Nothing -- -- g = f () () -tcSplitFunTysN :: Arity -- N: Number of desired args +tcSplitFunTysN :: Arity -- n: Number of desired args -> TcRhoType -> Either Arity -- Number of missing arrows ([TcSigmaType], -- Arg types (always N types) @@ -1854,9 +1861,9 @@ tc_eq_type view_fun orig_ty1 orig_ty2 = go True orig_env orig_ty1 orig_ty2 go vis _ (LitTy lit1) (LitTy lit2) = check vis $ lit1 == lit2 - go vis env (ForAllTy (TvBndr tv1 vis1) ty1) - (ForAllTy (TvBndr tv2 vis2) ty2) - = go (isVisibleArgFlag vis1) env (tyVarKind tv1) (tyVarKind tv2) + go vis env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = go (isVisibleArgFlag vis1) env (varType tv1) (varType tv2) <!> go vis (rnBndr2 env tv1 tv2) ty1 ty2 <!> check vis (vis1 == vis2) -- Make sure we handle all FunTy cases since falling through to the @@ -2161,9 +2168,9 @@ isInsolubleOccursCheck eq_rel tv ty NomEq -> go t1 || go t2 ReprEq -> go t1 go (FunTy t1 t2) = go t1 || go t2 - go (ForAllTy (TvBndr tv' _) inner_ty) + go (ForAllTy (Bndr tv' _) inner_ty) | tv' == tv = False - | otherwise = go (tyVarKind tv') || go inner_ty + | otherwise = go (varType tv') || go inner_ty go (CastTy ty _) = go ty -- ToDo: what about the coercion go (CoercionTy _) = False -- ToDo: what about the coercion go (TyConApp tc tys) @@ -2719,7 +2726,7 @@ sizeType = go go (LitTy {}) = 1 go (FunTy arg res) = go arg + go res + 1 go (AppTy fun arg) = go fun + go arg - go (ForAllTy (TvBndr tv vis) ty) + go (ForAllTy (Bndr tv vis) ty) | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 | otherwise = go ty + 1 go (CastTy ty _) = go ty diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index ad266f658f..05d49ae39d 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -36,7 +36,7 @@ import Module import HsSyn import DynFlags import Bag -import Var ( TyVarBndr(..) ) +import Var ( VarBndr(..) ) import CoreMap import Constants import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) @@ -401,7 +401,7 @@ mkTyConRepBinds :: TypeableStuff -> TypeRepTodo -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..}) = do -- Make a KindRep - let (bndrs, kind) = splitForAllTyVarBndrs (tyConKind tycon) + let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon) liftTc $ traceTc "mkTyConKindRepBinds" (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind) let ctx = mkDeBruijnContext (map binderVar bndrs) @@ -579,7 +579,7 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep | otherwise = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k) - new_kind_rep (ForAllTy (TvBndr var _) ty) + new_kind_rep (ForAllTy (Bndr var _) ty) = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) new_kind_rep (FunTy t1 t2) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index 045132e3e1..05a30fdf35 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -2196,7 +2196,7 @@ preCheck dflags ty_fam_ok tv ty fast_check (AppTy fun arg) = fast_check fun >> fast_check arg fast_check (CastTy ty co) = fast_check ty >> fast_check_co co fast_check (CoercionTy co) = fast_check_co co - fast_check (ForAllTy (TvBndr tv' _) ty) + fast_check (ForAllTy (Bndr tv' _) ty) | not impredicative_ok = OC_Bad | tv == tv' = ok | otherwise = do { fast_check_occ (tyVarKind tv') diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index df54dc2a94..dab9f2c308 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -50,7 +50,7 @@ import Name import VarEnv import VarSet import Id ( idType, idName ) -import Var ( TyVarBndr(..), mkTyVar ) +import Var ( VarBndr(..), mkTyVar ) import ErrUtils import DynFlags import Util @@ -481,11 +481,11 @@ check_type env ctxt rank ty (forAllEscapeErr env' ty tau_kind) } where - (tvbs, phi) = tcSplitForAllTyVarBndrs ty + (tvbs, phi) = tcSplitForAllVarBndrs ty (theta, tau) = tcSplitPhiTy phi tvs = binderVars tvbs - (env', _) = tidyTyCoVarBndrs env tvs + (env', _) = tidyVarBndrs env tvs tau_kind = typeKind tau phi_kind | null theta = tau_kind @@ -2079,7 +2079,7 @@ checkValidTelescope :: [TyConBinder] -- explicit vars (zonked) checkValidTelescope tvbs user_tyvars extra = do { let tvs = binderVars tvbs - (_, sorted_tidied_tvs) = tidyTyCoVarBndrs emptyTidyEnv $ + (_, sorted_tidied_tvs) = tidyVarBndrs emptyTidyEnv $ toposortTyVars tvs ; unless (go [] emptyVarSet (binderVars tvbs)) $ addErr $ @@ -2118,7 +2118,7 @@ fvType (TyConApp _ tys) = fvTypes tys fvType (LitTy {}) = [] fvType (AppTy fun arg) = fvType fun ++ fvType arg fvType (FunTy arg res) = fvType arg ++ fvType res -fvType (ForAllTy (TvBndr tv _) ty) +fvType (ForAllTy (Bndr tv _) ty) = fvType (tyVarKind tv) ++ filter (/= tv) (fvType ty) fvType (CastTy ty _) = fvType ty diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index 3c81935777..c766046ea8 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -29,10 +29,10 @@ module Coercion ( mkAxInstRHS, mkUnbranchedAxInstRHS, mkAxInstLHS, mkUnbranchedAxInstLHS, mkPiCo, mkPiCos, mkCoCast, - mkSymCo, mkTransCo, mkTransAppCo, + mkSymCo, mkTransCo, mkNthCo, nthCoRole, mkLRCo, mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, - mkForAllCo, mkForAllCos, mkHomoForAllCos, mkHomoForAllCos_NoRefl, + mkForAllCo, mkForAllCos, mkHomoForAllCos, mkPhantomCo, mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, mkAxiomInstCo, mkProofIrrelCo, @@ -54,6 +54,7 @@ module Coercion ( splitAppCo_maybe, splitFunCo_maybe, splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, @@ -198,7 +199,7 @@ ppr_co_ax_branch ppr_rhs , cab_rhs = rhs , cab_loc = loc }) = foldr1 (flip hangNotEmpty 2) - [ pprUserForAll (mkTyVarBinders Inferred (ee_tvs ++ cvs)) + [ pprUserForAll (mkTyCoVarBinders Inferred (ee_tvs ++ cvs)) , pprTypeApp fam_tc ee_lhs <+> ppr_rhs fam_tc rhs , text "-- Defined" <+> pprLoc loc ] where @@ -401,10 +402,22 @@ splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) splitFunCo_maybe _ = Nothing -splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) splitForAllCo_maybe _ = Nothing +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_ty_maybe (ForAllCo tv k_co co) + | isTyVar tv = Just (tv, k_co, co) +splitForAllCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +splitForAllCo_co_maybe (ForAllCo cv k_co co) + | isCoVar cv = Just (cv, k_co, co) +splitForAllCo_co_maybe _ = Nothing + ------------------------------------------------------- -- and some coercion kind stuff @@ -685,104 +698,81 @@ mkAppCos :: Coercion -> Coercion mkAppCos co1 cos = foldl' mkAppCo co1 cos --- | Like 'mkAppCo', but allows the second coercion to be other than --- nominal. See Note [mkTransAppCo]. Role r3 cannot be more stringent --- than either r1 or r2. -mkTransAppCo :: Role -- ^ r1 - -> Coercion -- ^ co1 :: ty1a ~r1 ty1b - -> Type -- ^ ty1a - -> Type -- ^ ty1b - -> Role -- ^ r2 - -> Coercion -- ^ co2 :: ty2a ~r2 ty2b - -> Type -- ^ ty2a - -> Type -- ^ ty2b - -> Role -- ^ r3 - -> Coercion -- ^ :: ty1a ty2a ~r3 ty1b ty2b -mkTransAppCo r1 co1 ty1a ty1b r2 co2 ty2a ty2b r3 --- How incredibly fiddly! Is there a better way?? - = case (r1, r2, r3) of - (_, _, Phantom) - -> mkPhantomCo kind_co (mkAppTy ty1a ty2a) (mkAppTy ty1b ty2b) - where -- ty1a :: k1a -> k2a - -- ty1b :: k1b -> k2b - -- ty2a :: k1a - -- ty2b :: k1b - -- ty1a ty2a :: k2a - -- ty1b ty2b :: k2b - kind_co1 = mkKindCo co1 -- :: k1a -> k2a ~N k1b -> k2b - kind_co = mkNthCo Nominal 1 kind_co1 -- :: k2a ~N k2b - - (_, _, Nominal) - -> ASSERT( r1 == Nominal && r2 == Nominal ) - mkAppCo co1 co2 - (Nominal, Nominal, Representational) - -> mkSubCo (mkAppCo co1 co2) - (_, Nominal, Representational) - -> ASSERT( r1 == Representational ) - mkAppCo co1 co2 - (Nominal, Representational, Representational) - -> go (mkSubCo co1) - (_ , _, Representational) - -> ASSERT( r1 == Representational && r2 == Representational ) - go co1 - where - go co1_repr - | Just (tc1b, tys1b) <- splitTyConApp_maybe ty1b - , nextRole ty1b == r2 - = (mkAppCo co1_repr (mkNomReflCo ty2a)) `mkTransCo` - (mkTyConAppCo Representational tc1b - (zipWith mkReflCo (tyConRolesRepresentational tc1b) tys1b - ++ [co2])) - - | Just (tc1a, tys1a) <- splitTyConApp_maybe ty1a - , nextRole ty1a == r2 - = (mkTyConAppCo Representational tc1a - (zipWith mkReflCo (tyConRolesRepresentational tc1a) tys1a - ++ [co2])) - `mkTransCo` - (mkAppCo co1_repr (mkNomReflCo ty2b)) +{- Note [Unused coercion variable in ForAllCo] - | otherwise - = pprPanic "mkTransAppCo" (vcat [ ppr r1, ppr co1, ppr ty1a, ppr ty1b - , ppr r2, ppr co2, ppr ty2a, ppr ty2b - , ppr r3 ]) +See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for +checking coercion variable in types. +To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: + +(1) In mkForAllCo, we check whether cv is a coercion variable + and whether it is not used in body_co. If so we construct a FunCo. +(2) We don't do this check in mkForAllCo. + In coercionKind, we use mkTyCoForAllTy to perform the check and construct + a FunTy when necessary. + +We chose (2) for two reasons: + +* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not + make a difference. +* even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. --- | Make a Coercion from a tyvar, a kind coercion, and a body coercion. --- The kind of the tyvar should be the left-hand kind of the kind coercion. -mkForAllCo :: TyVar -> Coercion -> Coercion -> Coercion +-} + + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +-- See Note [Unused coercion variable in ForAllCo] +mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion mkForAllCo tv kind_co co - | Just (ty, r) <- isReflCo_maybe co + | ASSERT( varType tv `eqType` (pFst $ coercionKind kind_co)) True + , Just (ty, r) <- isReflCo_maybe co , isGReflCo kind_co - = mkReflCo r (mkInvForAllTy tv ty) + = mkReflCo r (mkTyCoInvForAllTy tv ty) + | otherwise + = ForAllCo tv kind_co co + +-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl tv kind_co co + | ASSERT( varType tv `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( not (isReflCo co)) True + , isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfCo co) + = FunCo (coercionRole co) kind_co co | otherwise = ForAllCo tv kind_co co -- | Make nested ForAllCos -mkForAllCos :: [(TyVar, Coercion)] -> Coercion -> Coercion +mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion mkForAllCos bndrs co | Just (ty, r ) <- isReflCo_maybe co = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in - foldl' (flip $ uncurry ForAllCo) - (mkReflCo r (mkInvForAllTys (reverse (map fst refls_rev'd)) ty)) + foldl' (flip $ uncurry mkForAllCo_NoRefl) + (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) non_refls_rev'd | otherwise - = foldr (uncurry ForAllCo) co bndrs + = foldr (uncurry mkForAllCo_NoRefl) co bndrs --- | Make a Coercion quantified over a type variable; +-- | Make a Coercion quantified over a type/coercion variable; -- the variable has the same type in both sides of the coercion -mkHomoForAllCos :: [TyVar] -> Coercion -> Coercion +mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion mkHomoForAllCos tvs co | Just (ty, r) <- isReflCo_maybe co - = mkReflCo r (mkInvForAllTys tvs ty) + = mkReflCo r (mkTyCoInvForAllTys tvs ty) | otherwise = mkHomoForAllCos_NoRefl tvs co --- | Like 'mkHomoForAllCos', but doesn't check if the inner coercion --- is reflexive. -mkHomoForAllCos_NoRefl :: [TyVar] -> Coercion -> Coercion -mkHomoForAllCos_NoRefl tvs orig_co = foldr go orig_co tvs +-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. +mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl tvs orig_co + = ASSERT( not (isReflCo orig_co)) + foldr go orig_co tvs where - go tv co = ForAllCo tv (mkNomReflCo (tyVarKind tv)) co + go tv co = mkForAllCo_NoRefl tv (mkNomReflCo (varType tv)) co mkCoVarCo :: CoVar -> Coercion -- cv :: s ~# t @@ -831,7 +821,7 @@ mkAxInstCo role ax index tys cos = splitAt arity rtys ax_role = coAxiomRole ax --- worker function; just checks to see if it should produce Refl +-- worker function mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkAxiomInstCo ax index args = ASSERT( args `lengthIs` coAxiomArity ax index ) @@ -940,8 +930,9 @@ mkNthCo r n co go r 0 co | Just (ty, _) <- isReflCo_maybe co , Just (tv, _) <- splitForAllTy_maybe ty - = ASSERT( r == Nominal ) - mkReflCo r (tyVarKind tv) + = -- works for both tyvar and covar + ASSERT( r == Nominal ) + mkNomReflCo (varType tv) go r n co | Just (ty, r0) <- isReflCo_maybe co @@ -963,6 +954,8 @@ mkNthCo r n co kind_co -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) -- then (nth 0 co :: k1 ~N k2) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) go r n co@(FunCo r0 arg res) -- See Note [Function coercions] @@ -1058,9 +1051,10 @@ mkLRCo lr co -- | Instantiates a 'Coercion'. mkInstCo :: Coercion -> Coercion -> Coercion -mkInstCo (ForAllCo tv _kind_co body_co) co +mkInstCo (ForAllCo tcv _kind_co body_co) co | Just (arg, _) <- isReflCo_maybe co - = substCoWithUnchecked [tv] [arg] body_co + -- works for both tyvar and covar + = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co mkInstCo co arg = InstCo co arg -- | Given @ty :: k1@, @co :: k1 ~ k2@, @@ -1081,7 +1075,7 @@ mkGReflLeftCo r ty co -- instead of @isReflCo@ | otherwise = mkSymCo $ GRefl r ty (MCo co) --- | Given @ty :: k2@, @co :: k1 ~ k2@, @co2:: ty ~ ty'@, +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~ ty'@, -- produces @co' :: (ty |> co) ~r ty' -- It is not only a utility function, but it saves allocation when co -- is a GRefl coercion. @@ -1090,7 +1084,7 @@ mkCoherenceLeftCo r ty co co2 | isGReflCo co = co2 | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 --- | Given @ty :: k2@, @co :: k1 ~ k2@, @co2:: ty' ~ ty@, +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~ ty@, -- produces @co' :: ty' ~r (ty |> co) -- It is not only a utility function, but it saves allocation when co -- is a GRefl coercion. @@ -1310,11 +1304,18 @@ promoteCoercion co = case co of | otherwise -> mkKindCo co - ForAllCo _ _ g + ForAllCo tv _ g + | isTyVar tv -> promoteCoercion g + ForAllCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in Type + FunCo _ _ _ - -> mkNomReflCo liftedTypeKind + -> ASSERT( False ) + mkNomReflCo liftedTypeKind CoVarCo {} -> mkKindCo co HoleCo {} -> mkKindCo co @@ -1354,7 +1355,13 @@ promoteCoercion co = case co of -> mkKindCo co InstCo g _ - -> promoteCoercion g + | isForAllTy_ty ty1 + -> ASSERT( isForAllTy_ty ty2 ) + promoteCoercion g + | otherwise + -> ASSERT( False) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in Type KindCo _ -> ASSERT( False ) @@ -1373,15 +1380,21 @@ promoteCoercion co = case co of -- fails if this is not possible, if @g@ coerces between a forall and an -> -- or if second parameter has a representational role and can't be used -- with an InstCo. -instCoercion :: Pair Type -- type of the first coercion - -> CoercionN -- ^ must be nominal +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal -> Coercion -> Maybe CoercionN instCoercion (Pair lty rty) g w - | isForAllTy lty && isForAllTy rty + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] = Just $ mkInstCo g w' | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) | otherwise -- one forall, one funty... = Nothing @@ -1424,9 +1437,16 @@ mkPiCos :: Role -> [Var] -> Coercion -> Coercion mkPiCos r vs co = foldr (mkPiCo r) co vs -- | Make a forall 'Coercion', where both types related by the coercion --- are quantified over the same type variable. +-- are quantified over the same variable. mkPiCo :: Role -> Var -> Coercion -> Coercion mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co + | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) + -- We didn't call mkForAllCo here because if v does not appear + -- in co, the argement coercion will be nominal. But here we + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in SimplUtils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunCo r (mkReflCo r (varType v)) co | otherwise = mkFunCo r (mkReflCo r (varType v)) co -- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 @@ -1626,6 +1646,40 @@ thus giving *coercion*. This is what liftCoSubst does. In the presence of kind coercions, this is a bit of a hairy operation. So, we refer you to the paper introducing kind coercions, available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: \/k. \/a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> Nth 0 g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. -} -- ---------------------------------------------------- @@ -1643,21 +1697,21 @@ instance Outputable LiftingContext where type LiftCoEnv = VarEnv Coercion -- Maps *type variables* to *coercions*. -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. -- like liftCoSubstWith, but allows for existentially-bound types as well liftCoSubstWithEx :: Role -- desired role for output coercion -> [TyVar] -- universally quantified tyvars -> [Coercion] -- coercions to substitute for those - -> [TyVar] -- existentially quantified tyvars - -> [Type] -- types to be bound to ex vars + -> [TyCoVar] -- existentially quantified tycovars + -> [Type] -- types and coercions to be bound to ex vars -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) liftCoSubstWithEx role univs omegas exs rhos = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) - in (ty_co_subst psi role, substTyVars (lcSubstRight psi) exs) + in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion --- NB: This really can be called with CoVars, when optimising axioms. liftCoSubstWith r tvs cos ty = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty @@ -1681,32 +1735,30 @@ mkLiftingContext pairs mkSubstLiftingContext :: TCvSubst -> LiftingContext mkSubstLiftingContext subst = LC subst emptyVarEnv --- | Extend a lifting context with a new /type/ mapping. +-- | Extend a lifting context with a new mapping. extendLiftingContext :: LiftingContext -- ^ original LC - -> TyVar -- ^ new variable to map... + -> TyCoVar -- ^ new variable to map... -> Coercion -- ^ ...to this lifted version -> LiftingContext -- mappings to reflexive coercions are just substitutions extendLiftingContext (LC subst env) tv arg | Just (ty, _) <- isReflCo_maybe arg - = LC (extendTvSubst subst tv ty) env + = LC (extendTCvSubst subst tv ty) env | otherwise - = ASSERT( isTyVar tv ) - LC subst (extendVarEnv env tv arg) + = LC subst (extendVarEnv env tv arg) -- | Extend a lifting context with a new mapping, and extend the in-scope set extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC - -> TyVar -- ^ new variable to map... + -> TyCoVar -- ^ new variable to map... -> Coercion -- ^ to this coercion -> LiftingContext extendLiftingContextAndInScope (LC subst env) tv co = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co -- | Extend a lifting context with existential-variable bindings. --- This follows the lifting context extension definition in the --- "FC with Explicit Kind Equality" paper. +-- See Note [extendLiftingContextEx] extendLiftingContextEx :: LiftingContext -- ^ original lifting context - -> [(TyVar,Type)] -- ^ ex. var / value pairs + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs -> LiftingContext -- Note that this is more involved than extendLiftingContext. That function -- takes a coercion to extend with, so it's assumed that the caller has taken @@ -1716,12 +1768,33 @@ extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) -- This function adds bindings for *Nominal* coercions. Why? Because it -- works with existentially bound variables, which are considered to have -- nominal roles. + | isTyVar v = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) (extendVarEnv env v $ mkGReflRightCo Nominal ty (ty_co_subst lc Nominal (tyVarKind v))) in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + ASSERT( isCoVar v ) + let (_, _, s1, s2, r) = coVarKindsTypesRole v + lift_s1 = ty_co_subst lc r s1 + lift_s2 = ty_co_subst lc r s2 + kco = mkTyConAppCo Nominal (equalityTyCon r) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + -- | Erase the environments in a lifting context zapLiftingContext :: LiftingContext -> LiftingContext @@ -1730,8 +1803,8 @@ zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv -- | Like 'substForAllCoBndr', but works on a lifting context substForAllCoBndrUsingLC :: Bool -> (Coercion -> Coercion) - -> LiftingContext -> TyVar -> Coercion - -> (LiftingContext, TyVar, Coercion) + -> LiftingContext -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co = (LC subst' lc_env, tv', co') where @@ -1754,7 +1827,7 @@ ty_co_subst lc role ty go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) go r (FunTy ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) - go r (ForAllTy (TvBndr v _) ty) + go r (ForAllTy (Bndr v _) ty) = let (lc', v', h) = liftCoSubstVarBndr lc v in mkForAllCo v' h $! ty_co_subst lc' r ty go r ty@(LitTy {}) = ASSERT( r == Nominal ) @@ -1791,8 +1864,46 @@ liftCoSubstTyVar (LC subst env) r v | otherwise = Just $ mkReflCo r (substTyVar subst v) -liftCoSubstVarBndr :: LiftingContext -> TyVar - -> (LiftingContext, TyVar, Coercion) +{- Note [liftCoSubstVarBndr] + +callback: + We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in + FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type + in snd. + However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and + ignore the fourth componenet of the return value. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) liftCoSubstVarBndr lc tv = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in (lc', tv', h) @@ -1800,11 +1911,22 @@ liftCoSubstVarBndr lc tv callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) -- the callback must produce a nominal coercion -liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (Coercion, a)) +liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, CoercionN, a) +liftCoSubstVarBndrUsing fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) -> LiftingContext -> TyVar - -> (LiftingContext, TyVar, Coercion, a) -liftCoSubstVarBndrUsing fun lc@(LC subst cenv) old_var - = ( LC (subst `extendTCvInScope` new_var) new_cenv + -> (LiftingContext, TyVar, CoercionN, a) +liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isTyVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv , new_var, eta, stuff ) where old_kind = tyVarKind old_var @@ -1812,7 +1934,45 @@ liftCoSubstVarBndrUsing fun lc@(LC subst cenv) old_var Pair k1 _ = coercionKind eta new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) - lifted = GRefl Nominal (TyVarTy new_var) (MCo eta) + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, CoercionN, a) +liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isCoVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, kind_co, stuff ) + where + old_kind = coVarKind old_var + (eta, stuff) = fun lc old_kind + Pair k1 _ = coercionKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkNthCo role 2 eta' + eta2 = mkNthCo role 3 eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + kind_co = mkTyConAppCo Nominal (equalityTyCon role) + [ mkKindCo co1, mkKindCo co2 + , co1 , co2 ] + lifted = mkProofIrrelCo Nominal kind_co co1 co2 + new_cenv = extendVarEnv cenv old_var lifted -- | Is a var in the domain of a lifting context? @@ -1892,8 +2052,8 @@ seqCo (Refl ty) = seqType ty seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 -seqCo (ForAllCo tv k co) = seqType (tyVarKind tv) `seq` seqCo k - `seq` seqCo co +seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k + `seq` seqCo co seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 seqCo (CoVarCo cv) = cv `seq` () seqCo (HoleCo h) = coHoleCoVar h `seq` () @@ -1925,19 +2085,6 @@ seqCos (co:cos) = seqCo co `seq` seqCos cos The kind of a type, and of a coercion %* * %************************************************************************ - -Note [Computing a coercion kind and role] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To compute a coercion's kind is straightforward: see coercionKind. -But to compute a coercion's role, in the case for NthCo we need -its kind as well. So if we have two separate functions (one for kinds -and one for roles) we can get exponentially bad behaviour, since each -NthCo node makes a separate call to coercionKind, which traverses the -sub-tree again. This was part of the problem in Trac #9233. - -Solution: compute both together; hence coercionKindRole. We keep a -separate coercionKind function because it's a bit more efficient if -the kind is all you want. -} coercionType :: Coercion -> Type @@ -1960,8 +2107,8 @@ coercionKind co = go (GRefl _ ty (MCo co1)) = Pair ty (mkCastTy ty co1) go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 - go co@(ForAllCo tv1 k_co co1) - | isGReflCo k_co = mkInvForAllTy tv1 <$> go co1 + go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar + | isGReflCo k_co = mkTyCoInvForAllTy tv1 <$> go co1 -- kind_co always has kind @Type@, thus @isGReflCo@ | otherwise = go_forall empty_subst co where @@ -2016,6 +2163,7 @@ coercionKind co = go_forall subst (ForAllCo tv1 k_co co) -- See Note [Nested ForAllCos] + | isTyVar tv1 = mkInvForAllTy <$> Pair tv1 tv2 <*> go_forall subst' co where Pair _ k2 = go k_co @@ -2024,7 +2172,32 @@ coercionKind co = -- kind_co always has kind @Type@, thus @isGReflCo@ | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ TyVarTy tv2 `mkCastTy` mkSymCo k_co + go_forall subst (ForAllCo cv1 k_co co) + | isCoVar cv1 + = mkTyCoInvForAllTy <$> Pair cv1 cv2 <*> go_forall subst' co + where + Pair _ k2 = go k_co + r = coVarRole cv1 + eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) + eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendTCvInScope subst cv1 + | otherwise = extendCvSubst (extendTCvInScope subst cv2) + cv1 n_subst + go_forall subst other_co + -- when other_co is not a ForAllCo = substTy subst `pLiftSnd` go other_co {- @@ -2049,7 +2222,6 @@ coercionKinds :: [Coercion] -> Pair [Type] coercionKinds tys = sequenceA $ map coercionKind tys -- | Get a coercion's kind and role. --- Why both at once? See Note [Computing a coercion kind and role] coercionKindRole :: Coercion -> (Pair Type, Role) coercionKindRole co = (coercionKind co, coercionRole co) @@ -2134,14 +2306,40 @@ buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 = mkAppCo (go ty1a ty2a) (go ty1b ty2b) - go (ForAllTy (TvBndr tv1 _flag1) ty1) (ForAllTy (TvBndr tv2 _flag2) ty2) - = let kind_co = go (tyVarKind tv1) (tyVarKind tv2) + go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) + | isTyVar tv1 + = ASSERT( isTyVar tv2 ) + mkForAllCo tv1 kind_co (go ty1 ty2') + where kind_co = go (tyVarKind tv1) (tyVarKind tv2) in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co ty2' = substTyWithInScope in_scope [tv2] - [mkTyVarTy tv1 `mkCastTy` kind_co] - ty2 - in - mkForAllCo tv1 kind_co (go ty1 ty2') + [mkTyVarTy tv1 `mkCastTy` kind_co] + ty2 + + go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) + = ASSERT( isCoVar cv1 && isCoVar cv2 ) + mkForAllCo cv1 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkNthCo r 2 kind_co' + eta2 = mkNthCo r 3 kind_co' + + subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 go ty1@(LitTy lit1) _lit2 = ASSERT( case _lit2 of diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index 636c0dac44..a5cfba1afb 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -655,8 +655,8 @@ mkCoAxBranch tvs cvs lhs rhs roles loc , cab_loc = loc , cab_incomps = placeHolderIncomps } where - (env1, tvs1) = tidyTyCoVarBndrs emptyTidyEnv tvs - (env, cvs1) = tidyTyCoVarBndrs env1 cvs + (env1, tvs1) = tidyVarBndrs emptyTidyEnv tvs + (env, cvs1) = tidyVarBndrs env1 cvs -- See Note [Tidy axioms when we build them] -- all of the following code is here to avoid mutual dependencies with @@ -1369,11 +1369,11 @@ normalise_type ty ; (co2, nty2) <- go ty2 ; r <- getRole ; return (mkFunCo r co1 co2, mkFunTy nty1 nty2) } - go (ForAllTy (TvBndr tyvar vis) ty) - = do { (lc', tv', h, ki') <- normalise_tyvar_bndr tyvar + go (ForAllTy (Bndr tcvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar ; (co, nty) <- withLC lc' $ normalise_type ty ; let tv2 = setTyVarKind tv' ki' - ; return (mkForAllCo tv' h co, ForAllTy (TvBndr tv2 vis) nty) } + ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } go (TyVarTy tv) = normalise_tyvar tv go (CastTy ty co) = do { (nco, nty) <- go ty @@ -1400,12 +1400,13 @@ normalise_tyvar tv Nothing -> (mkReflCo r ty, ty) } where ty = mkTyVarTy tv -normalise_tyvar_bndr :: TyVar -> NormM (LiftingContext, TyVar, Coercion, Kind) -normalise_tyvar_bndr tv +normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) +normalise_var_bndr tcvar + -- works for both tvar and covar = do { lc1 <- getLC ; env <- getEnv ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal - ; return $ liftCoSubstVarBndrUsing callback lc1 tv } + ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } -- | a monad for the normalisation functions, reading 'FamInstEnvs', -- a 'LiftingContext', and a 'Role'. @@ -1504,7 +1505,7 @@ flattenTys in_scope tys = snd $ coreFlattenTys env tys -- *anywhere* in the types we're flattening, even if locally-bound in -- a forall. That way, we can ensure consistency both within and outside -- of that forall. - all_in_scope = in_scope `extendInScopeSetSet` allTyVarsInTys tys + all_in_scope = in_scope `extendInScopeSetSet` allTyCoVarsInTys tys env = emptyFlattenEnv all_in_scope coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type]) @@ -1539,10 +1540,10 @@ coreFlattenTy = go (env2, ty2') = go env1 ty2 in (env2, mkFunTy ty1' ty2') - go env (ForAllTy (TvBndr tv vis) ty) + go env (ForAllTy (Bndr tv vis) ty) = let (env1, tv') = coreFlattenVarBndr env tv (env2, ty') = go env1 ty in - (env2, ForAllTy (TvBndr tv' vis) ty') + (env2, ForAllTy (Bndr tv' vis) ty') go env ty@(LitTy {}) = (env, ty) @@ -1566,20 +1567,20 @@ coreFlattenCo env co covar = uniqAway in_scope (mkCoVar fresh_name kind') env2 = env1 { fe_subst = subst1 `extendTCvInScope` covar } -coreFlattenVarBndr :: FlattenEnv -> TyVar -> (FlattenEnv, TyVar) +coreFlattenVarBndr :: FlattenEnv -> TyCoVar -> (FlattenEnv, TyCoVar) coreFlattenVarBndr env tv | kind' `eqType` kind - = ( env { fe_subst = extendTvSubst old_subst tv (mkTyVarTy tv) } + = ( env { fe_subst = extendTCvSubst old_subst tv (mkTyCoVarTy tv) } -- override any previous binding for tv , tv) | otherwise - = let new_tv = uniqAway (getTCvInScope old_subst) (setTyVarKind tv kind') - new_subst = extendTvSubstWithClone old_subst tv new_tv + = let new_tv = uniqAway (getTCvInScope old_subst) (setVarType tv kind') + new_subst = extendTCvSubstWithClone old_subst tv new_tv in (env' { fe_subst = new_subst }, new_tv) where - kind = tyVarKind tv + kind = varType tv (env', kind') = coreFlattenTy env kind old_subst = fe_subst env @@ -1605,24 +1606,24 @@ coreFlattenTyFamApp env fam_tc fam_args FlattenEnv { fe_type_map = type_map , fe_subst = subst } = env --- | Get the set of all type variables mentioned anywhere in the list +-- | Get the set of all type/coercion variables mentioned anywhere in the list -- of types. These variables are not necessarily free. -allTyVarsInTys :: [Type] -> VarSet -allTyVarsInTys [] = emptyVarSet -allTyVarsInTys (ty:tys) = allTyVarsInTy ty `unionVarSet` allTyVarsInTys tys +allTyCoVarsInTys :: [Type] -> VarSet +allTyCoVarsInTys [] = emptyVarSet +allTyCoVarsInTys (ty:tys) = allTyCoVarsInTy ty `unionVarSet` allTyCoVarsInTys tys --- | Get the set of all type variables mentioned anywhere in a type. -allTyVarsInTy :: Type -> VarSet -allTyVarsInTy = go +-- | Get the set of all type/coercion variables mentioned anywhere in a type. +allTyCoVarsInTy :: Type -> VarSet +allTyCoVarsInTy = go where go (TyVarTy tv) = unitVarSet tv - go (TyConApp _ tys) = allTyVarsInTys tys + go (TyConApp _ tys) = allTyCoVarsInTys tys go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) go (FunTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) - go (ForAllTy (TvBndr tv _) ty) = unitVarSet tv `unionVarSet` - go (tyVarKind tv) `unionVarSet` - go ty - -- Don't remove the tv from the set! + go (ForAllTy (Bndr tv _) ty) = unitVarSet tv `unionVarSet` + go (tyVarKind tv) `unionVarSet` + go ty + -- Don't remove the tv from the set! go (LitTy {}) = emptyVarSet go (CastTy ty co) = go ty `unionVarSet` go_co co go (CoercionTy co) = go_co co diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index 5dd7c0c935..8a44b86f7e 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -55,6 +55,7 @@ opt_co2. Note [Optimising InstCo] ~~~~~~~~~~~~~~~~~~~~~~~~ +(1) tv is a type variable When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. Let's look at the typing rules. @@ -81,6 +82,30 @@ this operation already exists: it's called *lifting*, and defined in Coercion. We just need to enhance the lifting operation to be able to deal with an ambient substitution, which is why a LiftingContext stores a TCvSubst. +(2) cv is a coercion variable +Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +So we substitute the coercion variable c for the coercion +(h1 ~N (n1; h2; sym n2)) in g. -} optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo @@ -299,13 +324,15 @@ opt_co4 env _sym rep r (NthCo _r n co) | Just (ty, _) <- isReflCo_maybe co , n == 0 , Just (tv, _) <- splitForAllTy_maybe ty - = liftCoSubst (chooseRole rep r) env (tyVarKind tv) + -- works for both tyvar and covar + = liftCoSubst (chooseRole rep r) env (varType tv) opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) = ASSERT( r == r1 ) opt_co4_wrap env sym rep r (cos `getNth` n) opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) + -- works for both tyvar and covar = ASSERT( r == _r ) ASSERT( n == 0 ) opt_co4_wrap env sym rep Nominal eta @@ -348,26 +375,58 @@ opt_co4 env sym rep r (LRCo lr co) -- See Note [Optimising InstCo] opt_co4 env sym rep r (InstCo co1 arg) -- forall over type... - | Just (tv, kind_co, co_body) <- splitForAllCo_maybe co1 + | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 = opt_co4_wrap (extendLiftingContext env tv (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) arg')) + -- kind_co :: k1 ~ k2 + -- arg' :: (t1 :: k1) ~ (t2 :: k2) + -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) sym rep r co_body + -- forall over coercion... + | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 + , CoercionTy h1 <- t1 + , CoercionTy h2 <- t2 + = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 + in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + -- See if it is a forall after optimization -- If so, do an inefficient one-variable substitution, then re-optimize -- forall over type... - | Just (tv', kind_co', co_body') <- splitForAllCo_maybe co1' + | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co') arg')) False False r' co_body' + -- forall over coercion... + | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' + , CoercionTy h1 <- t1 + , CoercionTy h2 <- t2 + = let new_co = mk_new_co cv' kind_co' h1 h2 + in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) + False False r' co_body' + | otherwise = InstCo co1' arg' where co1' = opt_co4_wrap env sym rep r co1 r' = chooseRole rep r arg' = opt_co4_wrap env sym False Nominal arg - Pair _ t2 = coercionKind arg' + Pair t1 t2 = coercionKind arg' + + mk_new_co cv kind_co h1 h2 + = let -- h1 :: (t1 ~ t2) + -- h2 :: (t3 ~ t4) + -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) + -- n1 :: t1 ~ t3 + -- n2 :: t2 ~ t4 + -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) + r2 = coVarRole cv + kind_co' = downgradeRole r2 Nominal kind_co + n1 = mkNthCo r2 2 kind_co' + n2 = mkNthCo r2 3 kind_co' + in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 + (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) opt_co4 env sym _rep r (KindCo co) = ASSERT( r == Nominal ) @@ -446,8 +505,8 @@ opt_univ env sym prov role oty1 oty2 -- can't optimize the AppTy case because we can't build the kind coercions. - | Just (tv1, ty1) <- splitForAllTy_maybe oty1 - , Just (tv2, ty2) <- splitForAllTy_maybe oty2 + | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 -- NB: prov isn't interesting here either = let k1 = tyVarKind tv1 k2 = tyVarKind tv2 @@ -459,6 +518,24 @@ opt_univ env sym prov role oty1 oty2 in mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 + , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = varType cv1 + k2 = varType cv2 + r' = coVarRole cv1 + eta = mkUnivCo prov' Nominal k1 k2 + eta_d = downgradeRole r' Nominal eta + -- eta gets opt'ed soon, but not yet. + n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` + (mkNthCo r' 3 eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + in + mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + | otherwise = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 ty2 = substTyUnchecked (lcSubstRight env) oty2 @@ -595,28 +672,61 @@ opt_trans_rule is co1 co2@(AppCo co2a co2b) = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] -- Push transitivity inside forall +-- forall over types. opt_trans_rule is co1 co2 - | ForAllCo tv1 eta1 r1 <- co1 - , Just (tv2,eta2,r2) <- etaForAllCo_maybe co2 + | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 = push_trans tv1 eta1 r1 tv2 eta2 r2 - | ForAllCo tv2 eta2 r2 <- co2 - , Just (tv1,eta1,r1) <- etaForAllCo_maybe co1 + | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 = push_trans tv1 eta1 r1 tv2 eta2 r2 where push_trans tv1 eta1 r1 tv2 eta2 r2 -- Given: - -- co1 = \/ tv1 : eta1. r1 - -- co2 = \/ tv2 : eta2. r2 + -- co1 = /\ tv1 : eta1. r1 + -- co2 = /\ tv2 : eta2. r2 -- Wanted: - -- \/tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) - = fireTransRule "EtaAllTy" co1 co2 $ + -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') where is' = is `extendInScopeSet` tv1 r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + where + push_trans cv1 eta1 r1 cv2 eta2 r2 + -- Given: + -- co1 = /\ cv1 : eta1. r1 + -- co2 = /\ cv2 : eta2. r2 + -- Wanted: + -- n1 = nth 2 eta1 + -- n2 = nth 3 eta1 + -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) + = fireTransRule "EtaAllTy_co" co1 co2 $ + mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` cv1 + role = coVarRole cv1 + eta1' = downgradeRole role Nominal eta1 + n1 = mkNthCo role 2 eta1' + n2 = mkNthCo role 3 eta1' + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` n2]) + r2 + -- Push transitivity inside axioms opt_trans_rule is co1 co2 @@ -932,8 +1042,9 @@ compatible_co co1 co2 ------------- {- -etaForAllCo_maybe +etaForAllCo ~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe Suppose we have g : all a1:k1.t1 ~ all a2:k2.t2 @@ -955,16 +1066,34 @@ or g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) + eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) -} -etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) -- Try to make the coercion be of form (forall tv:kind_co. co) -etaForAllCo_maybe co - | ForAllCo tv kind_co r <- co +etaForAllCo_ty_maybe co + | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co = Just (tv, kind_co, r) | Pair ty1 ty2 <- coercionKind co - , Just (tv1, _) <- splitForAllTy_maybe ty1 - , isForAllTy ty2 + , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 + , isForAllTy_ty ty2 , let kind_co = mkNthCo Nominal 0 co = Just ( tv1, kind_co , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) @@ -972,6 +1101,28 @@ etaForAllCo_maybe co | otherwise = Nothing +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall cv:kind_co. co) +etaForAllCo_co_maybe co + | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (cv1, _) <- splitForAllTy_co_maybe ty1 + , isForAllTy_co ty2 + = let kind_co = mkNthCo Nominal 0 co + r = coVarRole cv1 + l_co = mkCoVarCo cv1 + kind_co' = downgradeRole r Nominal kind_co + r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` + l_co `mkTransCo` + (mkNthCo r 3 kind_co') + in Just ( cv1, kind_co + , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) + + | otherwise + = Nothing + etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) -- If possible, split a coercion -- g :: t1a t1b ~ t2a t2b @@ -1041,6 +1192,6 @@ and these two imply -} optForAllCoBndr :: LiftingContext -> Bool - -> TyVar -> Coercion -> (LiftingContext, TyVar, Coercion) + -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) optForAllCoBndr env sym = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 81cd2b0f95..b50327fc37 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -39,26 +39,30 @@ module TyCoRep ( -- * Functions over types mkTyConTy, mkTyVarTy, mkTyVarTys, - mkFunTy, mkFunTys, mkForAllTy, mkForAllTys, - mkPiTy, mkPiTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkFunTys, mkTyCoForAllTy, mkForAllTys, + mkForAllTy, + mkTyCoPiTy, mkTyCoPiTys, + mkPiTys, isTYPE, isLiftedTypeKind, isUnliftedTypeKind, isCoercionType, isRuntimeRepTy, isRuntimeRepVar, sameVis, -- * Functions over binders - TyBinder(..), TyVarBinder, - binderVar, binderVars, binderKind, binderArgFlag, + TyCoBinder(..), TyCoVarBinder, TyBinder, + binderVar, binderVars, binderType, binderArgFlag, delBinderVar, isInvisibleArgFlag, isVisibleArgFlag, isInvisibleBinder, isVisibleBinder, + isTyBinder, -- * Functions over coercions pickLR, -- * Pretty-printing pprType, pprParendType, pprPrecType, - pprTypeApp, pprTvBndr, pprTvBndrs, + pprTypeApp, pprTCvBndr, pprTCvBndrs, pprSigmaType, pprTheta, pprParendTheta, pprForAll, pprUserForAll, pprTyVar, pprTyVars, @@ -91,18 +95,20 @@ module TyCoRep ( TCvSubst(..), TvSubstEnv, CvSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, - mkTCvSubst, mkTvSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, getTvSubstEnv, getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, isInScope, notElemTCvSubst, setTvSubstEnv, setCvSubstEnv, zapTCvSubst, extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, - extendTCvSubst, + extendTCvSubst, extendTCvSubstWithClone, extendCvSubst, extendCvSubstWithClone, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, zipTvSubst, zipCvSubst, + zipTCvSubst, mkTvSubstPrs, substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, @@ -113,25 +119,28 @@ module TyCoRep ( substCoUnchecked, substCoWithUnchecked, substTyWithInScope, substTys, substTheta, - lookupTyVar, substTyVarBndr, substTyVarBndrs, + lookupTyVar, substCo, substCos, substCoVar, substCoVars, lookupCoVar, - substCoVarBndr, cloneTyVarBndr, cloneTyVarBndrs, - substTyVar, substTyVars, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, + substTyVar, substTyVars, substTyCoVars, substForAllCoBndr, - substTyVarBndrUsing, substForAllCoBndrUsing, + substVarBndrUsing, substForAllCoBndrUsing, checkValidSubst, isValidTCvSubst, -- * Tidying type related things up for printing tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyVarOcc, + tidyTyCoVarOcc, tidyTopType, tidyKind, tidyCo, tidyCos, - tidyTyVarBinder, tidyTyVarBinders, + tidyTyCoVarBinder, tidyTyCoVarBinders, -- * Sizes typeSize, coercionSize, provSize @@ -293,7 +302,7 @@ data Type -- can appear as the right hand side of a type synonym. | ForAllTy - {-# UNPACK #-} !TyVarBinder + {-# UNPACK #-} !TyCoVarBinder Type -- ^ A Πtype. | FunTy Type Type -- ^ t1 -> t2 Very common, so an important special case @@ -362,11 +371,11 @@ appropriate for the implementation of eqType? Anything smaller than ~ and homogeneous is an appropriate definition for equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any expression of type τ can be transmuted to one of type σ at any point by -casting. The same is true of types of type τ. So in some sense, τ and σ are -interchangeable. +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. But let's be more precise. If we examine the typing rules of FC (say, those in -http://www.cis.upenn.edu/~eir/papers/2015/equalities/equalities-extended.pdf) +https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) there are several places where the same metavariable is used in two different premises to a rule. (For example, see Ty_App.) There is an implicit equality check here. What definition of equality should we use? By convention, we use @@ -464,9 +473,35 @@ In sum, in order to uphold (EQ), we need the following three invariants: ForAllTy to a ForAllTy. (EQ2) No reflexive casts in CastTy. (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] in Type. These invariants are all documented above, in the declaration for Type. +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~ t2). e + +What type should we give to this expression? + (1) forall (co:t1 ~ t2) -> t + (2) (t1 ~ t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkTyCoForAllTy, we check whether the variable is a coercion +variable and whether it is used in the body. If so, it returns a FunTy +instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is unnecessary +when it is known from the context that the input variable is a type variable. +In those cases, we use mkForAllTy. -} -- | A type labeled 'KnotTied' might have knot-tied tycons in it. See @@ -476,40 +511,49 @@ type KnotTied ty = ty {- ********************************************************************** * * - TyBinder and ArgFlag + TyCoBinder and ArgFlag * * ********************************************************************** -} --- | A 'TyBinder' represents an argument to a function. TyBinders can be dependent --- ('Named') or nondependent ('Anon'). They may also be visible or not. --- See Note [TyBinders] -data TyBinder - = Named TyVarBinder -- A type-lambda binder - | Anon Type -- A term-lambda binder +-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [TyCoBinders] +data TyCoBinder + = Named TyCoVarBinder -- A type-lambda binder + | Anon Type -- A term-lambda binder. Type here can be CoercionTy. -- Visibility is determined by the type (Constraint vs. *) deriving Data.Data +-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' +-- in the 'Named' field. +type TyBinder = TyCoBinder + -- | Remove the binder's variable from the set, if the binder has -- a variable. -delBinderVar :: VarSet -> TyVarBinder -> VarSet -delBinderVar vars (TvBndr tv _) = vars `delVarSet` tv +delBinderVar :: VarSet -> TyCoVarBinder -> VarSet +delBinderVar vars (Bndr tv _) = vars `delVarSet` tv -- | Does this binder bind an invisible argument? -isInvisibleBinder :: TyBinder -> Bool -isInvisibleBinder (Named (TvBndr _ vis)) = isInvisibleArgFlag vis -isInvisibleBinder (Anon ty) = isPredTy ty +isInvisibleBinder :: TyCoBinder -> Bool +isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis +isInvisibleBinder (Anon ty) = isPredTy ty -- | Does this binder bind a visible argument? -isVisibleBinder :: TyBinder -> Bool +isVisibleBinder :: TyCoBinder -> Bool isVisibleBinder = not . isInvisibleBinder +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +isTyBinder :: TyCoBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True -{- Note [TyBinders] +{- Note [TyCoBinders] ~~~~~~~~~~~~~~~~~~~ -A ForAllTy contains a TyVarBinder. But a type can be decomposed -to a telescope consisting of a [TyBinder] +A ForAllTy contains a TyCoVarBinder. But a type can be decomposed +to a telescope consisting of a [TyCoBinder] -A TyBinder represents the type of binders -- that is, the type of an +A TyCoBinder represents the type of binders -- that is, the type of an argument to a Pi-type. GHC Core currently supports two different Pi-types: @@ -527,16 +571,16 @@ words, if `x` is either a function or a polytype, `x arg` makes sense (for an appropriate `arg`). -Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* A ForAllTy (used for both types and kinds) contains a TyVarBinder. - Each TyVarBinder - TvBndr a tvis +* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. + Each TyCoVarBinder + Bndr a tvis is equipped with tvis::ArgFlag, which says whether or not arguments for this binder should be visible (explicit) in source Haskell. * A TyCon contains a list of TyConBinders. Each TyConBinder - TvBndr a cvis + Bndr a cvis is equipped with cvis::TyConBndrVis, which says whether or not type and kind arguments for this TyCon should be visible (explicit) in source Haskell. @@ -545,18 +589,20 @@ This table summarises the visibility rules: --------------------------------------------------------------------------------------- | Occurrences look like this | GHC displays type as in Haskell source code -|----------------------------------------------------------------------- -| TvBndr a tvis :: TyVarBinder, in the binder of ForAllTy for a term +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term | tvis :: ArgFlag | tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f | tvis = Specified: f :: forall a. type Arg optional: f or f @Int | tvis = Required: T :: forall k -> type Arg required: T * -| This last form is illegal in terms: See Note [No Required TyBinder in terms] +| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] | -| TvBndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon | cvis :: TyConBndrVis | cvis = AnonTCB: T :: kind -> kind Required: T * | cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T | cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T | cvis = NamedTCB Required: T :: forall k -> kind Required: T * --------------------------------------------------------------------------------------- @@ -574,12 +620,12 @@ This table summarises the visibility rules: * Specified. Function defn, with signature (implicit forall): f2 :: a -> a; f2 x = x - So f2 gets the type f2 :: forall a. a->a, with 'a' Specified + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified even though 'a' is not bound in the source code by an explicit forall * Specified. Function defn, with signature (explicit forall): f3 :: forall a. a -> a; f3 x = x - So f3 gets the type f3 :: forall a. a->a, with 'a' Specified + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified * Inferred/Specified. Function signature with inferred kind polymorphism. f4 :: a b -> Int @@ -603,7 +649,7 @@ This table summarises the visibility rules: Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * The kind variable 'k' is Inferred, since it is not mentioned - Note that 'a' and 'b' correspond to /Anon/ TyBinders in T1's kind, + Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, and Anon binders don't have a visibility flag. (Or you could think of Anon having an implicit Required flag.) @@ -663,14 +709,14 @@ and its kind prints as * Inferred variables correspond to "generalized" variables from the Visible Type Applications paper (ESOP'16). -Note [No Required TyBinder in terms] +Note [No Required TyCoBinder in terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We don't allow Required foralls for term variables, including pattern synonyms and data constructors. Why? Because then an application would need a /compulsory/ type argument (possibly without an "@"?), thus (f Int); and we don't have concrete syntax for that. -We could change this decision, but Required, Named TyBinders are rare +We could change this decision, but Required, Named TyCoBinders are rare anyway. (Most are Anons.) -} @@ -731,14 +777,23 @@ These functions are here so that they can be used by TysPrim, which in turn is imported by Type -} --- named with "Only" to prevent naive use of mkTyVarTy mkTyVarTy :: TyVar -> Type mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) - TyVarTy v + TyVarTy v mkTyVarTys :: [TyVar] -> [Type] mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + infixr 3 `mkFunTy` -- Associates to the right -- | Make an arrow type mkFunTy :: Type -> Type -> Type @@ -748,18 +803,41 @@ mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys -mkForAllTy :: TyVar -> ArgFlag -> Type -> Type -mkForAllTy tv vis ty = ForAllTy (TvBndr tv vis) ty +-- | If tv is a coercion variable and it is not used in the body, returns +-- a FunTy, otherwise makes a forall type. +-- See Note [Unused coercion variable in ForAllTy] +mkTyCoForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkTyCoForAllTy tv vis ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = ASSERT( vis == Inferred ) + mkFunTy (varType tv) ty + | otherwise + = ForAllTy (Bndr tv vis) ty + +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty --- | Wraps foralls over the type using the provided 'TyVar's from left to right -mkForAllTys :: [TyVarBinder] -> Type -> Type +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [TyCoVarBinder] -> Type -> Type mkForAllTys tyvars ty = foldr ForAllTy ty tyvars -mkPiTy :: TyBinder -> Type -> Type -mkPiTy (Anon ty1) ty2 = FunTy ty1 ty2 -mkPiTy (Named tvb) ty = ForAllTy tvb ty +mkTyCoPiTy :: TyCoBinder -> Type -> Type +mkTyCoPiTy (Anon ty1) ty2 = FunTy ty1 ty2 +mkTyCoPiTy (Named (Bndr tv vis)) ty = mkTyCoForAllTy tv vis ty -mkPiTys :: [TyBinder] -> Type -> Type +-- | Like 'mkTyCoPiTy', but does not check the occurrence of the binder +mkPiTy:: TyCoBinder -> Type -> Type +mkPiTy (Anon ty1) ty2 = FunTy ty1 ty2 +mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty + +mkTyCoPiTys :: [TyCoBinder] -> Type -> Type +mkTyCoPiTys tbs ty = foldr mkTyCoPiTy ty tbs + +-- | Like 'mkTyCoPiTys', but does not check the occurrence of the binder +mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs -- | Does this type classify a core (unlifted) Coercion? @@ -883,7 +961,7 @@ data Coercion -- AppCo :: e -> N -> e -- See Note [Forall coercions] - | ForAllCo TyVar KindCoercion Coercion + | ForAllCo TyCoVar KindCoercion Coercion -- ForAllCo :: _ -> N -> e -> e | FunCo Role Coercion Coercion -- lift FunTy @@ -1080,9 +1158,10 @@ The typing rule is: ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) -First, the TyVar stored in a ForAllCo is really an optimisation: this field +First, the TyCoVar stored in a ForAllCo is really an optimisation: this field should be a Name, as its kind is redundant. Thinking of the field as a Name is helpful in understanding what a ForAllCo means. +The kind of TyCoVar always matches the left-hand kind of the coercion. The idea is that kind_co gives the two kinds of the tyvar. See how, in the conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. @@ -1479,7 +1558,7 @@ In core, we get MkG :: forall (a :: *). (a ~ Bool) -> G a Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want -a proof that ('MkG co1 a1) ~ ('MkG co2 a2). This will have to be +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be TyConAppCo Nominal MkG [co3, co4] where @@ -1494,7 +1573,7 @@ Here, co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) where co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) - co5 = TyConAppCo Nominal (~) [<*>, <*>, co4, <Bool>] + co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>] %************************************************************************ @@ -1561,10 +1640,10 @@ tyCoFVsOfType (ForAllTy bndr ty) a b c = tyCoFVsBndr bndr (tyCoFVsOfType ty) a tyCoFVsOfType (CastTy ty co) a b c = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) a b c tyCoFVsOfType (CoercionTy co) a b c = tyCoFVsOfCo co a b c -tyCoFVsBndr :: TyVarBinder -> FV -> FV +tyCoFVsBndr :: TyCoVarBinder -> FV -> FV -- Free vars of (forall b. <thing with fvs>) -tyCoFVsBndr (TvBndr tv _) fvs = (delFV tv fvs) - `unionFV` tyCoFVsOfType (tyVarKind tv) +tyCoFVsBndr (Bndr tv _) fvs = (delFV tv fvs) + `unionFV` tyCoFVsOfType (varType tv) -- | Returns free variables of types, including kind variables as -- a non-deterministic set. For type synonyms it does /not/ expand the @@ -1681,9 +1760,9 @@ coVarsOfType (TyConApp _ tys) = coVarsOfTypes tys coVarsOfType (LitTy {}) = emptyVarSet coVarsOfType (AppTy fun arg) = coVarsOfType fun `unionVarSet` coVarsOfType arg coVarsOfType (FunTy arg res) = coVarsOfType arg `unionVarSet` coVarsOfType res -coVarsOfType (ForAllTy (TvBndr tv _) ty) +coVarsOfType (ForAllTy (Bndr tv _) ty) = (coVarsOfType ty `delVarSet` tv) - `unionVarSet` coVarsOfType (tyVarKind tv) + `unionVarSet` coVarsOfType (varType tv) coVarsOfType (CastTy ty co) = coVarsOfType ty `unionVarSet` coVarsOfCo co coVarsOfType (CoercionTy co) = coVarsOfCo co @@ -1757,11 +1836,11 @@ closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems -- positions. (See @Note [Kind annotations on TyConApps]@ in "TcSplice" for an -- explanation of what an injective position is.) injectiveVarsOfBinder :: TyConBinder -> FV -injectiveVarsOfBinder (TvBndr tv vis) = +injectiveVarsOfBinder (Bndr tv vis) = case vis of - AnonTCB -> injectiveVarsOfType (tyVarKind tv) + AnonTCB -> injectiveVarsOfType (varType tv) NamedTCB Required -> unitFV tv `unionFV` - injectiveVarsOfType (tyVarKind tv) + injectiveVarsOfType (varType tv) NamedTCB _ -> emptyFV -- | Returns the free variables of a 'Type' that are in injective positions. @@ -1782,7 +1861,7 @@ injectiveVarsOfType = go filterByList (inj ++ repeat True) tys -- Oversaturated arguments to a tycon are -- always injective, hence the repeat True - go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go (tyVarKind (binderVar tvb)) + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go (binderType tvb) `unionFV` go ty go LitTy{} = emptyFV go (CastTy ty _) = go ty @@ -1804,6 +1883,9 @@ noFreeVarsOfMCo :: MCoercion -> Bool noFreeVarsOfMCo MRefl = True noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes = all noFreeVarsOfType + -- | Returns True if this coercion has no free variables. Should be the same as -- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. noFreeVarsOfCo :: Coercion -> Bool @@ -1903,7 +1985,7 @@ The same rules apply to other substitutions (notably CoreSubst.Subst) Then if we use the in-scope set {b}, satisfying (SIa), there is a danger we will rename the forall'd variable to 'x' by mistake, getting this: - forall x. (List b, x, x) + forall x. (Maybe b, x, x) Breaking (SIb) caused the bug from #11371. Note: if the free vars of the range of the substitution are freshly created, @@ -1944,7 +2026,7 @@ nevertheless we add 'b' to the TvSubstEnv, because b's kind does change This invariant has several crucial consequences: -* In substTyVarBndr, we need extend the TvSubstEnv +* In substVarBndr, we need extend the TvSubstEnv - if the unique has changed - or if the kind has changed @@ -2018,6 +2100,10 @@ mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst -- ^ Make a TCvSubst with specified tyvar subst and empty covar subst mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv +mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv + getTvSubstEnv :: TCvSubst -> TvSubstEnv getTvSubstEnv (TCvSubst _ env _) = env @@ -2076,13 +2162,19 @@ extendTCvSubst subst v ty | otherwise = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) +extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst extendTvSubst (TCvSubst in_scope tenv cenv) tv ty = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv -extendTvSubstBinderAndInScope :: TCvSubst -> TyBinder -> Type -> TCvSubst -extendTvSubstBinderAndInScope subst (Named bndr) ty - = extendTvSubstAndInScope subst (binderVar bndr) ty +extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty + = ASSERT( isTyVar v ) + extendTvSubstAndInScope subst v ty extendTvSubstBinderAndInScope subst (Anon _) _ = subst @@ -2118,6 +2210,10 @@ extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst extendTvSubstList subst tvs tys = foldl2 extendTvSubst subst tvs tys +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst -- Works when the ranges are disjoint unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) @@ -2161,6 +2257,18 @@ zipCvSubst cvs cos where cenv = zipCoEnv cvs cos +zipTCvSubst :: [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst tcvs tys + | debugIsOn + , neLength tcvs tys + = pprTrace "zipTCvSubst" (ppr tcvs $$ ppr tys) emptyTCvSubst + | otherwise + = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) + where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst _ _ subst = subst -- empty case + -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst @@ -2454,10 +2562,10 @@ subst_ty subst ty go (TyConApp tc tys) = let args = map go tys in args `seqList` TyConApp tc args go (FunTy arg res) = (FunTy $! go arg) $! go res - go (ForAllTy (TvBndr tv vis) ty) - = case substTyVarBndrUnchecked subst tv of + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of (subst', tv') -> - (ForAllTy $! ((TvBndr $! tv') vis)) $! + (ForAllTy $! ((Bndr $! tv') vis)) $! (subst_ty subst' ty) go (LitTy n) = LitTy $! n go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) @@ -2473,6 +2581,14 @@ substTyVar (TCvSubst _ tenv _) tv substTyVars :: TCvSubst -> [TyVar] -> [Type] substTyVars subst = map $ substTyVar subst +substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + lookupTyVar :: TCvSubst -> TyVar -> Maybe Type -- See Note [Extending the TCvSubst] lookupTyVar (TCvSubst _ tenv _) tv @@ -2523,8 +2639,9 @@ subst_co subst co in args' `seqList` mkTyConAppCo r tc args' go (AppCo co arg) = (mkAppCo $! go co) $! go arg go (ForAllCo tv kind_co co) - = case substForAllCoBndrUnchecked subst tv kind_co of { (subst', tv', kind_co') -> - ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co } + = case substForAllCoBndrUnchecked subst tv kind_co of + (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 go (CoVarCo cv) = substCoVar subst cv go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos @@ -2550,7 +2667,8 @@ subst_co subst co go_hole h@(CoercionHole { ch_co_var = cv }) = h { ch_co_var = updateVarType go_ty cv } -substForAllCoBndr :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion) +substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) substForAllCoBndr subst = substForAllCoBndrUsing False (substCo subst) subst @@ -2559,18 +2677,27 @@ substForAllCoBndr subst -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substCoUnchecked to -- substCo and remove this function. Please don't use in new code. -substForAllCoBndrUnchecked :: TCvSubst -> TyVar -> Coercion -> (TCvSubst, TyVar, Coercion) +substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst = substForAllCoBndrUsing False (substCoUnchecked subst) subst -- See Note [Sym and ForAllCo] substForAllCoBndrUsing :: Bool -- apply sym to binder? - -> (Coercion -> Coercion) -- transformation to kind co - -> TCvSubst -> TyVar -> Coercion - -> (TCvSubst, TyVar, Coercion) -substForAllCoBndrUsing sym sco (TCvSubst in_scope tenv cenv) - old_var old_kind_co - = ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sym sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var + +substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> KindCoercion + -> (TCvSubst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + = ASSERT( isTyVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv , new_var, new_kind_co ) where new_env | no_change && not sym = delVarEnv tenv old_var @@ -2585,9 +2712,38 @@ substForAllCoBndrUsing sym sco (TCvSubst in_scope tenv cenv) | otherwise = sco old_kind_co Pair new_ki1 _ = coercionKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) +substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> CoVar -> KindCoercion + -> (TCvSubst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ASSERT( isCoVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change && not sym = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair h1 h2 = coercionKind new_kind_co + + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type + new_var_type | sym = h2 + | otherwise = h1 + substCoVar :: TCvSubst -> CoVar -> Coercion substCoVar (TCvSubst _ _ cenv) cv = case lookupVarEnv cenv cv of @@ -2597,7 +2753,7 @@ substCoVar (TCvSubst _ _ cenv) cv substCoVars :: TCvSubst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) @@ -2606,13 +2762,28 @@ substTyVarBndr = substTyVarBndrUsing substTy substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr --- | Like 'substTyVarBndr' but disables sanity checks. +substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. -- The problems that the sanity checks in substTy catch are described in -- Note [The substitution invariant]. -- The goal of #11371 is to migrate all the calls of substTyUnchecked to -- substTy and remove this function. Please don't use in new code. -substTyVarBndrUnchecked :: TCvSubst -> TyVar -> (TCvSubst, TyVar) -substTyVarBndrUnchecked = substTyVarBndrUsing substTyUnchecked +substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (TCvSubst -> Type -> Type) + -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v -- | Substitute a tyvar in a binding position, returning an -- extended subst and a new tyvar. @@ -2649,13 +2820,18 @@ substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var setTyVarKind old_var (subst_fn subst old_ki) -- The uniqAway part makes sure the new variable is not already in scope -substCoVarBndr :: TCvSubst -> CoVar -> (TCvSubst, CoVar) -substCoVarBndr subst@(TCvSubst in_scope tenv cenv) old_var +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var = ASSERT( isCoVar old_var ) (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) where new_co = mkCoVarCo new_var - no_kind_change = all noFreeVarsOfType [t1, t2] + no_kind_change = noFreeVarsOfTypes [t1, t2] no_change = new_var == old_var && no_kind_change new_cenv | no_change = delVarEnv cenv old_var @@ -2665,8 +2841,8 @@ substCoVarBndr subst@(TCvSubst in_scope tenv cenv) old_var subst_old_var = mkCoVar (varName old_var) new_var_type (_, _, t1, t2, role) = coVarKindsTypesRole old_var - t1' = substTy subst t1 - t2' = substTy subst t2 + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 new_var_type = mkCoercionType role t1' t2' -- It's important to do the substitution for coercions, -- because they can have free type variables @@ -2803,18 +2979,18 @@ instance Outputable TyLit where pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType -pprForAll :: [TyVarBinder] -> SDoc +pprForAll :: [TyCoVarBinder] -> SDoc pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) -- | Print a user-level forall; see Note [When to print foralls] -pprUserForAll :: [TyVarBinder] -> SDoc +pprUserForAll :: [TyCoVarBinder] -> SDoc pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr -pprTvBndrs :: [TyVarBinder] -> SDoc -pprTvBndrs tvs = sep (map pprTvBndr tvs) +pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) -pprTvBndr :: TyVarBinder -> SDoc -pprTvBndr = pprTyVar . binderVar +pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar pprTyVars :: [TyVar] -> SDoc pprTyVars tvs = sep (map pprTyVar tvs) @@ -2830,11 +3006,11 @@ pprTyVar tv where kind = tyVarKind tv -instance Outputable TyBinder where +instance Outputable TyCoBinder where ppr (Anon ty) = text "[anon]" <+> ppr ty - ppr (Named (TvBndr v Required)) = ppr v - ppr (Named (TvBndr v Specified)) = char '@' <> ppr v - ppr (Named (TvBndr v Inferred)) = braces (ppr v) + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) ----------------- instance Outputable Coercion where -- defined here to avoid orphans @@ -2908,7 +3084,7 @@ This catches common situations, such as a type siguature which means f :: forall k. forall (m :: k->*) (a :: k). m a We really want to see both the "forall k" and the kind signatures -on m and a. The latter comes from pprTvBndr. +on m and a. The latter comes from pprTCvBndr. Note [Infix type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2972,32 +3148,32 @@ ppSuggestExplicitKinds -- an interface file. -- -- It doesn't change the uniques at all, just the print names. -tidyTyCoVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) -tidyTyCoVarBndrs (occ_env, subst) tvs - = mapAccumL tidyTyCoVarBndr tidy_env' tvs +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs (occ_env, subst) tvs + = mapAccumL tidyVarBndr tidy_env' tvs where -- Seed the occ_env with clashes among the names, see -- Node [Tidying multiple names at once] in OccName - -- Se still go through tidyTyCoVarBndr so that each kind variable is tidied + -- Se still go through tidyVarBndr so that each kind variable is tidied -- with the correct tidy_env occs = map getHelpfulOccName tvs tidy_env' = (avoidClashesOccEnv occ_env occs, subst) -tidyTyCoVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -tidyTyCoVarBndr tidy_env@(occ_env, subst) tyvar - = case tidyOccName occ_env (getHelpfulOccName tyvar) of - (occ_env', occ') -> ((occ_env', subst'), tyvar') +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (occ_env', occ') -> ((occ_env', subst'), var') where - subst' = extendVarEnv subst tyvar tyvar' - tyvar' = setTyVarKind (setTyVarName tyvar name') kind' - kind' = tidyKind tidy_env (tyVarKind tyvar) + subst' = extendVarEnv subst var var' + var' = setVarType (setVarName var name') type' + type' = tidyType tidy_env (varType var) name' = tidyNameOcc name occ' - name = tyVarName tyvar + name = varName var getHelpfulOccName :: TyCoVar -> OccName -getHelpfulOccName tyvar = occ1 +getHelpfulOccName var = occ1 where - name = tyVarName tyvar + name = varName var occ = getOccName name -- A TcTyVar with a System Name is probably a unification variable; -- when we tidy them we give them a trailing "0" (or 1 etc) @@ -3005,21 +3181,21 @@ getHelpfulOccName tyvar = occ1 -- Plus, indicating a unification variable in this way is a -- helpful clue for users occ1 | isSystemName name - , isTcTyVar tyvar + , isTcTyVar var = mkTyVarOcc (occNameString occ ++ "0") | otherwise = occ -tidyTyVarBinder :: TidyEnv -> TyVarBndr TyVar vis - -> (TidyEnv, TyVarBndr TyVar vis) -tidyTyVarBinder tidy_env (TvBndr tv vis) - = (tidy_env', TvBndr tv' vis) +tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyTyCoVarBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) where - (tidy_env', tv') = tidyTyCoVarBndr tidy_env tv + (tidy_env', tv') = tidyVarBndr tidy_env tv -tidyTyVarBinders :: TidyEnv -> [TyVarBndr TyVar vis] - -> (TidyEnv, [TyVarBndr TyVar vis]) -tidyTyVarBinders = mapAccumL tidyTyVarBinder +tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyTyCoVarBinders = mapAccumL tidyTyCoVarBinder --------------- tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv @@ -3028,7 +3204,7 @@ tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv tidyFreeTyCoVars (full_occ_env, var_env) tyvars = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) - --------------- +--------------- tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars @@ -3036,19 +3212,19 @@ tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) -- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name -- using the environment if one has not already been allocated. See --- also 'tidyTyCoVarBndr' +-- also 'tidyVarBndr' tidyOpenTyCoVar env@(_, subst) tyvar = case lookupVarEnv subst tyvar of Just tyvar' -> (env, tyvar') -- Already substituted Nothing -> let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) - in tidyTyCoVarBndr env' tyvar -- Treat it as a binder + in tidyVarBndr env' tyvar -- Treat it as a binder --------------- -tidyTyVarOcc :: TidyEnv -> TyVar -> TyVar -tidyTyVarOcc env@(_, subst) tv +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tv = case lookupVarEnv subst tv of - Nothing -> updateTyVarKind (tidyType env) tv + Nothing -> updateVarType (tidyType env) tv Just tv' -> tv' --------------- @@ -3058,7 +3234,7 @@ tidyTypes env tys = map (tidyType env) tys --------------- tidyType :: TidyEnv -> Type -> Type tidyType _ (LitTy n) = LitTy n -tidyType env (TyVarTy tv) = TyVarTy (tidyTyVarOcc env tv) +tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys in args `seqList` TyConApp tycon args tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) @@ -3066,7 +3242,7 @@ tidyType env (FunTy fun arg) = (FunTy $! (tidyType env fun)) $! (tidyType e tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty where (tvs, vis, body_ty) = splitForAllTys' ty - (env', tvs') = tidyTyCoVarBndrs env tvs + (env', tvs') = tidyVarBndrs env tvs tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) @@ -3074,16 +3250,16 @@ tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) -- The following two functions differ from mkForAllTys and splitForAllTys in that -- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but -- how should they be named? -mkForAllTys' :: [(TyVar, ArgFlag)] -> Type -> Type +mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs where - strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((TvBndr $! tv) $! vis)) $! ty + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty -splitForAllTys' :: Type -> ([TyVar], [ArgFlag], Type) +splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) splitForAllTys' ty = go ty [] [] where - go (ForAllTy (TvBndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) - go ty tvs viss = (reverse tvs, reverse viss, ty) + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) --------------- @@ -3131,7 +3307,7 @@ tidyCo env@(_, subst) co in args `seqList` TyConAppCo r tc args go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) - where (envp, tvp) = tidyTyCoVarBndr env tv + where (envp, tvp) = tidyVarBndr env tv -- the case above duplicates a bit of work in tidying h and the kind -- of tv. But the alternative is to use coercionKind, which seems worse. go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 @@ -3186,7 +3362,7 @@ typeSize (LitTy {}) = 1 typeSize (TyVarTy {}) = 1 typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 -typeSize (ForAllTy (TvBndr tv _) t) = typeSize (tyVarKind tv) + typeSize t +typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) typeSize (CastTy ty co) = typeSize ty + coercionSize co typeSize (CoercionTy co) = coercionSize co diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot index 9f886dc458..5af8c1d57f 100644 --- a/compiler/types/TyCoRep.hs-boot +++ b/compiler/types/TyCoRep.hs-boot @@ -11,7 +11,7 @@ data Coercion data UnivCoProvenance data TCvSubst data TyLit -data TyBinder +data TyCoBinder data MCoercion type PredType = Type diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index d5347fc534..0acde99f49 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -17,7 +17,7 @@ module TyCon( RuntimeRepInfo(..), TyConFlavour(..), -- * TyConBinder - TyConBinder, TyConBndrVis(..), + TyConBinder, TyConBndrVis(..), TyConTyCoBinder, mkNamedTyConBinder, mkNamedTyConBinders, mkAnonTyConBinder, mkAnonTyConBinders, tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, @@ -134,7 +134,7 @@ import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType ) import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind , vecCountTyCon, vecElemTyCon, liftedTypeKind , mkFunKind, mkForAllKind ) -import {-# SOURCE #-} DataCon ( DataCon, dataConExTyVars, dataConFieldLabels +import {-# SOURCE #-} DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels , dataConTyCon, dataConFullSig ) import Binary @@ -248,7 +248,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs Here's the FC version of the above declaration: - data R:TPair a where + data R:TPair a b where X1 :: R:TPair Int Bool X2 :: a -> b -> R:TPair a b axiom ax_pr :: T (a,b) ~R R:TPair a b @@ -266,7 +266,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs DataFamInstTyCon T [(a,b)] ax_pr * Notice that T is NOT translated to a FC type function; it just - becomes a "data type" with no constructors, which can be coerced inot + becomes a "data type" with no constructors, which can be coerced into R:TInt, R:TPair by the axioms. These axioms axioms come into play when (and *only* when) you - use a data constructor @@ -312,7 +312,7 @@ parent class. However there is an important sharing relationship between * the tyConTyVars of the parent Class - * the tyConTyvars of the associated TyCon + * the tyConTyVars of the associated TyCon class C a b where data T p a @@ -386,13 +386,16 @@ See also: ************************************************************************ * * - TyConBinder + TyConBinder, TyConTyCoBinder * * ************************************************************************ -} -type TyConBinder = TyVarBndr TyVar TyConBndrVis - -- See also Note [TyBinders] in TyCoRep +type TyConBinder = VarBndr TyVar TyConBndrVis + +-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really +-- contain CoVar. +type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis data TyConBndrVis = NamedTCB ArgFlag @@ -403,21 +406,23 @@ instance Outputable TyConBndrVis where ppr AnonTCB = text "AnonTCB" mkAnonTyConBinder :: TyVar -> TyConBinder -mkAnonTyConBinder tv = TvBndr tv AnonTCB +mkAnonTyConBinder tv = ASSERT( isTyVar tv) + Bndr tv AnonTCB mkAnonTyConBinders :: [TyVar] -> [TyConBinder] mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder -- The odd argument order supports currying -mkNamedTyConBinder vis tv = TvBndr tv (NamedTCB vis) +mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) + Bndr tv (NamedTCB vis) mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] -- The odd argument order supports currying mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs tyConBinderArgFlag :: TyConBinder -> ArgFlag -tyConBinderArgFlag (TvBndr _ vis) = tyConBndrVisArgFlag vis +tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag tyConBndrVisArgFlag (NamedTCB vis) = vis @@ -427,18 +432,18 @@ isNamedTyConBinder :: TyConBinder -> Bool -- Identifies kind variables -- E.g. data T k (a:k) = blah -- Here 'k' is a NamedTCB, a variable used in the kind of other binders -isNamedTyConBinder (TvBndr _ (NamedTCB {})) = True -isNamedTyConBinder _ = False +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False -isVisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too -isVisibleTyConBinder (TvBndr _ tcb_vis) = isVisibleTcbVis tcb_vis +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis isVisibleTcbVis :: TyConBndrVis -> Bool isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis isVisibleTcbVis AnonTCB = True -isInvisibleTyConBinder :: TyVarBndr tv TyConBndrVis -> Bool +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool -- Works for IfaceTyConBinder too isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) @@ -446,8 +451,8 @@ mkTyConKind :: [TyConBinder] -> Kind -> Kind mkTyConKind bndrs res_kind = foldr mk res_kind bndrs where mk :: TyConBinder -> Kind -> Kind - mk (TvBndr tv AnonTCB) k = mkFunKind (tyVarKind tv) k - mk (TvBndr tv (NamedTCB vis)) k = mkForAllKind tv vis k + mk (Bndr tv AnonTCB) k = mkFunKind (varType tv) k + mk (Bndr tv (NamedTCB vis)) k = mkForAllKind tv vis k tyConTyVarBinders :: [TyConBinder] -- From the TyCon -> [TyVarBinder] -- Suitable for the foralls of a term function @@ -455,16 +460,17 @@ tyConTyVarBinders :: [TyConBinder] -- From the TyCon tyConTyVarBinders tc_bndrs = map mk_binder tc_bndrs where - mk_binder (TvBndr tv tc_vis) = mkTyVarBinder vis tv + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv where vis = case tc_vis of AnonTCB -> Specified NamedTCB Required -> Specified NamedTCB vis -> vis +-- Returns only tyvars, as covars are always inferred tyConVisibleTyVars :: TyCon -> [TyVar] tyConVisibleTyVars tc - = [ tv | TvBndr tv vis <- tyConBinders tc + = [ tv | Bndr tv vis <- tyConBinders tc , isVisibleTcbVis vis ] {- Note [Building TyVarBinders from TyConBinders] @@ -476,12 +482,12 @@ TyConBinders but TyVarBinders (used in forall-type) E.g: * From data T a = MkT (Maybe a) we are going to make a data constructor with type MkT :: forall a. Maybe a -> T a - See the TyVarBinders passed to buildDataCon + See the TyCoVarBinders passed to buildDataCon * From class C a where { op :: a -> Maybe a } we are going to make a default method $dmop :: forall a. C a => a -> Maybe a - See the TyVarBindres passed to mkSigmaTy in mkDefaultMethodType + See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType Both of these are user-callable. (NB: default methods are not callable directly by the user but rather via the code generated by 'deriving', @@ -495,18 +501,18 @@ Here is an example: The TyCon has - tyConTyBinders = [ Named (TvBndr (k :: *) Inferred), Anon (k->*), Anon k ] + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] The TyConBinders 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 TyVarBinders should be +That is, its TyCoVarBinders should be - dataConUnivTyVarBinders = [ TvBndr (k:*) Inferred - , TvBndr (a:k->*) Specified - , TvBndr (b:k) Specified ] + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: - variable names from the TyConBinders @@ -515,43 +521,46 @@ So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: 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 +the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] +in TyCoRep), so we change it to Specified when making MkT's TyCoBinders -} {- Note [The binders/kind/arity fields of a TyCon] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ All TyCons have this group of fields - tyConBinders :: [TyConBinder] - tyConResKind :: Kind - tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders - tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind - tyConArity :: Arity -- Cached = length tyConBinders + tyConBinders :: [TyConBinder/TyConTyCoBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders They fit together like so: -* tyConBinders gives the telescope of type variables on the LHS of the +* tyConBinders gives the telescope of type/coercion variables on the LHS of the type declaration. For example: type App a (b :: k) = a b - tyConBinders = [ TvBndr (k::*) (NamedTCB Inferred) - , TvBndr (a:k->*) AnonTCB - , TvBndr (b:k) AnonTCB ] + tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) + , Bndr (a:k->*) AnonTCB + , Bndr (b:k) AnonTCB ] Note that that are three binders here, including the kind variable k. -- See Note [TyVarBndrs, TyVarBinders, TyConBinders, and visibility] in TyCoRep +- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for what the visibility flag means. -* Each TyConBinder tyConBinders has a TyVar, and that TyVar may - scope over some other part of the TyCon's definition. Eg - type T a = a->a +* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a we have - tyConBinders = [ TvBndr (a:*) AnonTCB ] - synTcRhs = a->a + tyConBinders = [ Bndr (a:*) AnonTCB ] + synTcRhs = a -> a So the 'a' scopes over the synTcRhs * From the tyConBinders and tyConResKind we can get the tyConKind @@ -569,11 +578,11 @@ They fit together like so: So it's just (length tyConBinders) -} -instance Outputable tv => Outputable (TyVarBndr tv TyConBndrVis) where - ppr (TvBndr v AnonTCB) = text "anon" <+> parens (ppr v) - ppr (TvBndr v (NamedTCB Required)) = text "req" <+> parens (ppr v) - ppr (TvBndr v (NamedTCB Specified)) = text "spec" <+> parens (ppr v) - ppr (TvBndr v (NamedTCB Inferred)) = text "inf" <+> parens (ppr v) +instance Outputable tv => Outputable (VarBndr tv TyConBndrVis) where + ppr (Bndr v AnonTCB) = text "anon" <+> parens (ppr v) + ppr (Bndr v (NamedTCB Required)) = text "req" <+> parens (ppr v) + ppr (Bndr v (NamedTCB Specified)) = text "spec" <+> parens (ppr v) + ppr (Bndr v (NamedTCB Inferred)) = text "inf" <+> parens (ppr v) instance Binary TyConBndrVis where put_ bh AnonTCB = putByte bh 0 @@ -802,7 +811,7 @@ data TyCon tyConName :: Name, -- ^ Same Name as the data constructor -- See Note [The binders/kind/arity fields of a TyCon] - tyConBinders :: [TyConBinder], -- ^ Full binders + tyConBinders :: [TyConTyCoBinder], -- ^ Full binders tyConResKind :: Kind, -- ^ Result kind tyConKind :: Kind, -- ^ Kind of this TyCon tyConArity :: Arity, -- ^ Arity @@ -1648,7 +1657,7 @@ mkFamilyTyCon name binders res_kind resVar flav parent inj -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance mkPromotedDataCon :: DataCon -> Name -> TyConRepName - -> [TyConBinder] -> Kind -> [Role] + -> [TyConTyCoBinder] -> Kind -> [Role] -> RuntimeRepInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info = PromotedDataCon { @@ -1780,8 +1789,9 @@ isNewTyCon :: TyCon -> Bool isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True isNewTyCon _ = False --- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands --- into, and (possibly) a coercion from the representation type to the @newtype@. +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. -- Returns @Nothing@ if this is not possible. unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, @@ -1804,7 +1814,7 @@ isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of TupleTyCon {} -> True DataTyCon{ data_cons = [data_con] } - -> null (dataConExTyVars data_con) + -> null (dataConExTyCoVars data_con) NewTyCon {} -> True _ -> False isProductTyCon _ = False @@ -1816,7 +1826,7 @@ isDataProductTyCon_maybe :: TyCon -> Maybe DataCon isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons = [con] } - | null (dataConExTyVars con) -- non-existential + | null (dataConExTyCoVars con) -- non-existential -> Just con TupleTyCon { data_con = con } -> Just con @@ -1828,10 +1838,10 @@ isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) = case rhs of DataTyCon { data_cons = cons } | cons `lengthExceeds` 1 - , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this? + , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? -> Just cons SumTyCon { data_cons = cons } - | all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this? + | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? -> Just cons _ -> Nothing isDataSumTyCon_maybe _ = Nothing diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 180af3862c..bda3602815 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -15,12 +15,12 @@ module Type ( -- $representation_types TyThing(..), Type, ArgFlag(..), KindOrType, PredType, ThetaType, - Var, TyVar, isTyVar, TyCoVar, TyBinder, TyVarBinder, + Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, KnotTied, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, - getCastedTyVar_maybe, tyVarKind, + getCastedTyVar_maybe, tyVarKind, varType, mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, @@ -36,12 +36,15 @@ module Type ( splitListTyConApp_maybe, repSplitTyConApp_maybe, - mkForAllTy, mkForAllTys, mkInvForAllTys, mkSpecForAllTys, - mkVisForAllTys, mkInvForAllTy, - splitForAllTys, splitForAllTyVarBndrs, + mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInvForAllTy, mkInvForAllTys, + splitForAllTys, splitForAllVarBndrs, splitForAllTy_maybe, splitForAllTy, + splitForAllTy_ty_maybe, splitForAllTy_co_maybe, splitPiTy_maybe, splitPiTy, splitPiTys, - mkPiTy, mkPiTys, mkTyConBindersPreferAnon, + mkTyCoPiTy, mkTyCoPiTys, mkTyConBindersPreferAnon, + mkPiTys, mkLamType, mkLamTypes, piResultTy, piResultTys, applyTysX, dropForAlls, @@ -90,14 +93,16 @@ module Type ( -- ** Binders sameVis, - mkTyVarBinder, mkTyVarBinders, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinders, mkAnonBinder, - isAnonTyBinder, isNamedTyBinder, - binderVar, binderVars, binderKind, binderArgFlag, - tyBinderType, tyBinderVar_maybe, + isAnonTyCoBinder, isNamedTyCoBinder, + binderVar, binderVars, binderType, binderArgFlag, + tyCoBinderType, tyCoBinderVar_maybe, + tyBinderType, binderRelevantType_maybe, caseBinder, isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, isInvisibleBinder, - tyConBindersTyBinders, + tyConBindersTyCoBinders, -- ** Common type constructors funTyCon, @@ -105,6 +110,7 @@ module Type ( -- ** Predicates on types isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy, isCoercionTy_maybe, isCoercionType, isForAllTy, + isForAllTy_ty, isForAllTy_co, isPiTy, isTauTy, isFamFreeTy, isValidJoinPointType, @@ -163,6 +169,7 @@ module Type ( emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, mkTCvSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, notElemTCvSubst, getTvSubstEnv, setTvSubstEnv, zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, @@ -170,7 +177,9 @@ module Type ( extendTCvSubst, extendCvSubst, extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, extendTvSubstWithClone, + extendTCvSubstWithClone, isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, isEmptyTCvSubst, unionTCvSubst, @@ -181,12 +190,13 @@ module Type ( substTyWithUnchecked, substCoUnchecked, substCoWithUnchecked, substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, -- * Pretty-printing pprType, pprParendType, pprPrecType, pprTypeApp, pprTyThingCategory, pprShortTyThing, - pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, + pprTCvBndr, pprTCvBndrs, pprForAll, pprUserForAll, pprSigmaType, ppSuggestExplicitKinds, pprTheta, pprThetaArrowTy, pprClassPred, pprKind, pprParendKind, pprSourceTyCon, @@ -198,12 +208,12 @@ module Type ( tidyType, tidyTypes, tidyOpenType, tidyOpenTypes, tidyOpenKind, - tidyTyCoVarBndr, tidyTyCoVarBndrs, tidyFreeTyCoVars, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, tidyOpenTyCoVar, tidyOpenTyCoVars, - tidyTyVarOcc, + tidyTyCoVarOcc, tidyTopType, tidyKind, - tidyTyVarBinder, tidyTyVarBinders + tidyTyCoVarBinder, tidyTyCoVarBinders ) where #include "HsVersions.h" @@ -307,7 +317,7 @@ import Control.Arrow ( first, second ) -- -- You don't normally have to worry about this, as the utility functions in -- this module will automatically convert a source into a representation type --- if they are spotted, to the best of it's abilities. If you don't want this +-- if they are spotted, to the best of its abilities. If you don't want this -- to happen, use the equivalent functions from the "TcType" module. {- @@ -404,9 +414,9 @@ expandTypeSynonyms ty go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) go subst (FunTy arg res) = mkFunTy (go subst arg) (go subst res) - go subst (ForAllTy (TvBndr tv vis) t) - = let (subst', tv') = substTyVarBndrUsing go subst tv in - ForAllTy (TvBndr tv' vis) (go subst' t) + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) go subst (CoercionTy co) = mkCoercionTy (go_co subst co) @@ -476,11 +486,11 @@ on all variables and binding sites. Primarily used for zonking. Note [Efficiency for mapCoercion ForAllCo case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. -It stores a TyVar and a Coercion, where the kind of the TyVar always matches +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches the left-hand kind of the coercion. This is convenient lots of the time, but not when mapping a function over a coercion. -The problem is that tcm_tybinder will affect the TyVar's kind and +The problem is that tcm_tybinder will affect the TyCoVar's kind and mapCoercion will affect the Coercion, and we hope that the results will be the same. Even if they are the same (which should generally happen with correct algorithms), then there is an efficiency issue. In particular, @@ -514,7 +524,7 @@ data TyCoMapper env m -- ^ What to do with coercion holes. -- See Note [Coercion holes] in TyCoRep. - , tcm_tybinder :: env -> TyVar -> ArgFlag -> m (env, TyVar) + , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) -- ^ The returned env is used in the extended scope , tcm_tycon :: TyCon -> m TyCon @@ -526,7 +536,7 @@ data TyCoMapper env m {-# INLINABLE mapType #-} -- See Note [Specialising mappers] mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar - , tcm_tybinder = tybinder, tcm_tycon = tycon }) + , tcm_tycobinder = tycobinder, tcm_tycon = tycon }) env ty = go ty where @@ -539,10 +549,10 @@ mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar = do { tc' <- tycon tc ; mktyconapp tc' <$> mapM go tys } go (FunTy arg res) = FunTy <$> go arg <*> go res - go (ForAllTy (TvBndr tv vis) inner) - = do { (env', tv') <- tybinder env tv vis + go (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis ; inner' <- mapType mapper env' inner - ; return $ ForAllTy (TvBndr tv' vis) inner' } + ; return $ ForAllTy (Bndr tv' vis) inner' } go ty@(LitTy {}) = return ty go (CastTy ty co) = mkcastty <$> go ty <*> mapCoercion mapper env co go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co @@ -555,7 +565,7 @@ mapType mapper@(TyCoMapper { tcm_smart = smart, tcm_tyvar = tyvar mapCoercion :: Monad m => TyCoMapper env m -> env -> Coercion -> m Coercion mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar - , tcm_hole = cohole, tcm_tybinder = tybinder + , tcm_hole = cohole, tcm_tycobinder = tycobinder , tcm_tycon = tycon }) env co = go co @@ -571,7 +581,7 @@ mapCoercion mapper@(TyCoMapper { tcm_smart = smart, tcm_covar = covar go (AppCo c1 c2) = mkappco <$> go c1 <*> go c2 go (ForAllCo tv kind_co co) = do { kind_co' <- go kind_co - ; (env', tv') <- tybinder env tv Inferred + ; (env', tv') <- tycobinder env tv Inferred ; co' <- mapCoercion mapper env' co ; return $ mkforallco tv' kind_co' co' } -- See Note [Efficiency for mapCoercion ForAllCo case] @@ -638,7 +648,7 @@ getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' | otherwise = repGetTyVar_maybe ty -- | If the type is a tyvar, possibly under a cast, returns it, along --- with the coercion. Thus, the co is :: kind tv ~N kind type +-- with the coercion. Thus, the co is :: kind tv ~N kind ty getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) @@ -912,7 +922,7 @@ pprUserTypeErrorTy ty = Note [Representation of function types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Functions (e.g. Int -> Char) are can be thought of as being applications +Functions (e.g. Int -> Char) can be thought of as being applications of funTyCon (known in Haskell surface syntax as (->)), (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) @@ -973,26 +983,25 @@ funArgTy ty | Just ty' <- coreView ty = funArgTy ty' funArgTy (FunTy arg _res) = arg funArgTy ty = pprPanic "funArgTy" (ppr ty) +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" piResultTy :: HasDebugCallStack => Type -> Type -> Type piResultTy ty arg = case piResultTy_maybe ty arg of Just res -> res Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) piResultTy_maybe :: Type -> Type -> Maybe Type - --- ^ Just like 'piResultTys' but for a single argument --- Try not to iterate 'piResultTy', because it's inefficient to substitute --- one variable at a time; instead use 'piResultTys" piResultTy_maybe ty arg | Just ty' <- coreView ty = piResultTy_maybe ty' arg | FunTy _ res <- ty = Just res - | ForAllTy (TvBndr tv _) res <- ty + | ForAllTy (Bndr tv _) res <- ty = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfTypes [arg,res] - in Just (substTy (extendTvSubst empty_subst tv arg) res) + in Just (substTy (extendTCvSubst empty_subst tv arg) res) | otherwise = Nothing @@ -1027,30 +1036,30 @@ piResultTys ty orig_args@(arg:args) | FunTy _ res <- ty = piResultTys res args - | ForAllTy (TvBndr tv _) res <- ty - = go (extendVarEnv emptyTvSubstEnv tv arg) res args + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args | otherwise = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) where - in_scope = mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) - go :: TvSubstEnv -> Type -> [Type] -> Type - go tv_env ty [] = substTy (mkTvSubst in_scope tv_env) ty + go :: TCvSubst -> Type -> [Type] -> Type + go subst ty [] = substTy subst ty - go tv_env ty all_args@(arg:args) + go subst ty all_args@(arg:args) | Just ty' <- coreView ty - = go tv_env ty' all_args + = go subst ty' all_args | FunTy _ res <- ty - = go tv_env res args + = go subst res args - | ForAllTy (TvBndr tv _) res <- ty - = go (extendVarEnv tv_env tv arg) res args + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args - | not (isEmptyVarEnv tv_env) -- See Note [Care with kind instantiation] - = go emptyTvSubstEnv - (substTy (mkTvSubst in_scope tv_env) ty) + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) all_args | otherwise @@ -1088,7 +1097,7 @@ So T (forall b. b->b) * :: (b -> b)[ b :-> *] :: * -> * -In other words wwe must intantiate the forall! +In other words we must intantiate the forall! Similarly (Trac #15428) S :: forall k f. k -> f k @@ -1217,6 +1226,21 @@ newTyConInstRhs tycon tys ~~~~~~ A casted type has its *kind* casted into something new. +Note [Weird typing rule for ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the (truncated) typing rule for the dependent ForAllTy: + +inner : kind +------------------------------------ +ForAllTy (Bndr tyvar vis) inner : kind + +inner : TYPE r +------------------------------------ +ForAllTy (Bndr covar vis) inner : TYPE + +Note that when inside the binder is a tyvar, neither the inner type nor for +ForAllTy itself have to have kind *! But, it means that we should push any kind +casts through the ForAllTy. The only trouble is avoiding capture. -} splitCastTy_maybe :: Type -> Maybe (Type, Coercion) @@ -1235,16 +1259,30 @@ mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note -- fails under splitFunTy_maybe. This happened with the cheaper check -- in test dependent/should_compile/dynamic-paper. -mkCastTy (CastTy ty co1) co2 = mkCastTy ty (co1 `mkTransCo` co2) -- (EQ3) from the Note - -- call mkCastTy again for the reflexivity check +mkCastTy (CastTy ty co1) co2 + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co2) + -- call mkCastTy again for the reflexivity check + +mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co + -- (EQ4) from the Note + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) + else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) + mkCastTy ty co = CastTy ty co -tyConBindersTyBinders :: [TyConBinder] -> [TyBinder] --- Return the tyConBinders in TyBinder form -tyConBindersTyBinders = map to_tyb +tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] +-- Return the tyConBinders in TyCoBinder form +tyConBindersTyCoBinders = map to_tyb where - to_tyb (TvBndr tv (NamedTCB vis)) = Named (TvBndr tv vis) - to_tyb (TvBndr tv AnonTCB) = Anon (tyVarKind tv) + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv AnonTCB) = Anon (varType tv) {- -------------------------------------------------------------------- @@ -1296,26 +1334,40 @@ interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. -- | Make a dependent forall over an Inferred (as opposed to Specified) -- variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkFunTy (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like mkTyCoInvForAllTy, but tv should be a tyvar mkInvForAllTy :: TyVar -> Type -> Type mkInvForAllTy tv ty = ASSERT( isTyVar tv ) - ForAllTy (TvBndr tv Inferred) ty + ForAllTy (Bndr tv Inferred) ty -- | Like mkForAllTys, but assumes all variables are dependent and Inferred, -- a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar mkInvForAllTys :: [TyVar] -> Type -> Type -mkInvForAllTys tvs ty = ASSERT( all isTyVar tvs ) - foldr mkInvForAllTy ty tvs +mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs -- | Like mkForAllTys, but assumes all variables are dependent and specified, -- a common case mkSpecForAllTys :: [TyVar] -> Type -> Type mkSpecForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys [ TvBndr tv Specified | tv <- tvs ] + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Specified | tv <- tvs ] -- | Like mkForAllTys, but assumes all variables are dependent and visible mkVisForAllTys :: [TyVar] -> Type -> Type mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) - mkForAllTys [ TvBndr tv Required | tv <- tvs ] + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] mkLamType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or an implicit forall type, depending @@ -1326,51 +1378,67 @@ mkLamTypes :: [Var] -> Type -> Type -- ^ 'mkLamType' for multiple type or value arguments mkLamType v ty - | isTyVar v = ForAllTy (TvBndr v Inferred) ty - | otherwise = FunTy (varType v) ty + | isCoVar v + , v `elemVarSet` tyCoVarsOfType ty + = ForAllTy (Bndr v Inferred) ty + | isTyVar v + = ForAllTy (Bndr v Inferred) ty + | otherwise + = FunTy (varType v) ty mkLamTypes vs ty = foldr mkLamType ty vs -- | Given a list of type-level vars and a result kind, --- makes TyBinders, preferring anonymous binders +-- makes TyCoBinders, preferring anonymous binders -- if the variable is, in fact, not dependent. -- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) --- We want (k:*) Named, (a;k) Anon, (c:k) Anon +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon -- --- All binders are /visible/. +-- All non-coercion binders are /visible/. mkTyConBindersPreferAnon :: [TyVar] -> Type -> [TyConBinder] -mkTyConBindersPreferAnon vars inner_ty = fst (go vars) +mkTyConBindersPreferAnon vars inner_ty = ASSERT( all isTyVar vars) + fst (go vars) where go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars go [] = ([], tyCoVarsOfType inner_ty) - go (v:vs) | v `elemVarSet` fvs - = ( TvBndr v (NamedTCB Required) : binders + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders , fvs `delVarSet` v `unionVarSet` kind_vars ) | otherwise - = ( TvBndr v AnonTCB : binders + = ( Bndr v AnonTCB : binders , fvs `unionVarSet` kind_vars ) where (binders, fvs) = go vs kind_vars = tyCoVarsOfType $ tyVarKind v --- | Take a ForAllTy apart, returning the list of tyvars and the result type. +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. -- This always succeeds, even if it returns only an empty list. Note that the -- result type returned may have free variables that were bound by a forall. -splitForAllTys :: Type -> ([TyVar], Type) +splitForAllTys :: Type -> ([TyCoVar], Type) splitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs - split _ (ForAllTy (TvBndr tv _) ty) tvs = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like splitForAllTys, but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitTyVarForAllTys :: Type -> ([TyVar], Type) +splitTyVarForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) -- | Like 'splitPiTys' but split off only /named/ binders. -splitForAllTyVarBndrs :: Type -> ([TyVarBinder], Type) -splitForAllTyVarBndrs ty = split ty ty [] +splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) +splitForAllVarBndrs ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs split _ (ForAllTy b res) bs = split res res (b:bs) split orig_ty _ bs = (reverse bs, orig_ty) -{-# INLINE splitForAllTyVarBndrs #-} +{-# INLINE splitForAllVarBndrs #-} -- | Checks whether this is a proper forall (with a named binder) isForAllTy :: Type -> Bool @@ -1378,6 +1446,18 @@ isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' isForAllTy (ForAllTy {}) = True isForAllTy _ = False +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' +isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True +isForAllTy_ty _ = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' +isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True +isForAllTy_co _ = False + -- | Is this a function or forall? isPiTy :: Type -> Bool isPiTy ty | Just ty' <- coreView ty = isForAllTy ty' @@ -1386,7 +1466,7 @@ isPiTy (FunTy {}) = True isPiTy _ = False -- | Take a forall type apart, or panics if that is not possible. -splitForAllTy :: Type -> (TyVar, Type) +splitForAllTy :: Type -> (TyCoVar, Type) splitForAllTy ty | Just answer <- splitForAllTy_maybe ty = answer | otherwise = pprPanic "splitForAllTy" (ppr ty) @@ -1401,16 +1481,32 @@ dropForAlls ty = go ty -- | Attempts to take a forall type apart, but only if it's a proper forall, -- with a named binder -splitForAllTy_maybe :: Type -> Maybe (TyVar, Type) +splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTy_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' - go (ForAllTy (TvBndr tv _) ty) = Just (tv, ty) - go _ = Nothing + go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. +splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_ty_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. +splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_co_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) + go _ = Nothing -- | Attempts to take a forall type apart; works with proper foralls and -- functions -splitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) splitPiTy_maybe ty = go ty where go ty | Just ty' <- coreView ty = go ty' @@ -1419,14 +1515,14 @@ splitPiTy_maybe ty = go ty go _ = Nothing -- | Takes a forall type apart, or panics -splitPiTy :: Type -> (TyBinder, Type) +splitPiTy :: Type -> (TyCoBinder, Type) splitPiTy ty | Just answer <- splitPiTy_maybe ty = answer | otherwise = pprPanic "splitPiTy" (ppr ty) --- | Split off all TyBinders to a type, splitting both proper foralls +-- | Split off all TyCoBinders to a type, splitting both proper foralls -- and functions -splitPiTys :: Type -> ([TyBinder], Type) +splitPiTys :: Type -> ([TyCoBinder], Type) splitPiTys ty = split ty ty where split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' @@ -1438,11 +1534,11 @@ splitPiTys ty = split ty ty -- Like splitPiTys, but returns only *invisible* binders, including constraints -- Stops at the first visible binder -splitPiTysInvisible :: Type -> ([TyBinder], Type) +splitPiTysInvisible :: Type -> ([TyCoBinder], Type) splitPiTysInvisible ty = split ty ty [] where split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs - split _ (ForAllTy b@(TvBndr _ vis) res) bs + split _ (ForAllTy b@(Bndr _ vis) res) bs | isInvisibleArgFlag vis = split res res (Named b : bs) split _ (FunTy arg res) bs | isPredTy arg = split res res (Anon arg : bs) @@ -1480,11 +1576,11 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) partitionInvisibles tc get_ty = go emptyTCvSubst (tyConKind tc) where go _ _ [] = ([], []) - go subst (ForAllTy (TvBndr tv vis) res_ki) (x:xs) + go subst (ForAllTy (Bndr tv vis) res_ki) (x:xs) | isVisibleArgFlag vis = second (x :) (go subst' res_ki xs) | otherwise = first (x :) (go subst' res_ki xs) where - subst' = extendTvSubst subst tv (get_ty x) + subst' = extendTCvSubst subst tv (get_ty x) go subst (TyVarTy tv) xs | Just ki <- lookupTyVar subst tv = go subst ki xs go _ _ xs = ([], xs) -- something is ill-kinded. But this can happen @@ -1505,43 +1601,49 @@ isTauTy (CoercionTy _) = False -- Not sure about this {- %************************************************************************ %* * - TyBinders + TyCoBinders %* * %************************************************************************ -} -- | Make an anonymous binder -mkAnonBinder :: Type -> TyBinder +mkAnonBinder :: Type -> TyCoBinder mkAnonBinder = Anon -- | Does this binder bind a variable that is /not/ erased? Returns -- 'True' for anonymous binders. -isAnonTyBinder :: TyBinder -> Bool -isAnonTyBinder (Named {}) = False -isAnonTyBinder (Anon {}) = True +isAnonTyCoBinder :: TyCoBinder -> Bool +isAnonTyCoBinder (Named {}) = False +isAnonTyCoBinder (Anon {}) = True -isNamedTyBinder :: TyBinder -> Bool -isNamedTyBinder (Named {}) = True -isNamedTyBinder (Anon {}) = False +isNamedTyCoBinder :: TyCoBinder -> Bool +isNamedTyCoBinder (Named {}) = True +isNamedTyCoBinder (Anon {}) = False -tyBinderVar_maybe :: TyBinder -> Maybe TyVar -tyBinderVar_maybe (Named tv) = Just $ binderVar tv -tyBinderVar_maybe _ = Nothing +tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar +tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv +tyCoBinderVar_maybe _ = Nothing -tyBinderType :: TyBinder -> Type +tyCoBinderType :: TyCoBinder -> Type -- Barely used -tyBinderType (Named tvb) = binderKind tvb +tyCoBinderType (Named tvb) = binderType tvb +tyCoBinderType (Anon ty) = ty + +tyBinderType :: TyBinder -> Type +tyBinderType (Named (Bndr tv _)) + = ASSERT( isTyVar tv ) + tyVarKind tv tyBinderType (Anon ty) = ty -- | Extract a relevant type, if there is one. -binderRelevantType_maybe :: TyBinder -> Maybe Type +binderRelevantType_maybe :: TyCoBinder -> Maybe Type binderRelevantType_maybe (Named {}) = Nothing binderRelevantType_maybe (Anon ty) = Just ty -- | Like 'maybe', but for binders. -caseBinder :: TyBinder -- ^ binder to scrutinize - -> (TyVarBinder -> a) -- ^ named case - -> (Type -> a) -- ^ anonymous case +caseBinder :: TyCoBinder -- ^ binder to scrutinize + -> (TyCoVarBinder -> a) -- ^ named case + -> (Type -> a) -- ^ anonymous case -> a caseBinder (Named v) f _ = f v caseBinder (Anon t) _ d = d t @@ -1834,7 +1936,7 @@ data PredTree = ClassPred Class [Type] | EqPred EqRel Type Type | IrredPred PredType - | ForAllPred [TyVarBinder] [PredType] PredType + | ForAllPred [TyCoVarBinder] [PredType] PredType -- ForAllPred: see Note [Quantified constraints] in TcCanonical -- NB: There is no TuplePred case -- Tuple predicates like (Eq a, Ord b) are just treated @@ -1851,7 +1953,7 @@ classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of | Just clas <- tyConClass_maybe tc -> ClassPred clas tys - _ | (tvs, rho) <- splitForAllTyVarBndrs ev_ty + _ | (tvs, rho) <- splitForAllVarBndrs ev_ty , (theta, pred) <- splitFunTys rho , not (null tvs && null theta) -> ForAllPred tvs theta pred @@ -1997,7 +2099,6 @@ pprSourceTyCon tycon | otherwise = ppr tycon --- @isTauTy@ tests if a type has no foralls isFamFreeTy :: Type -> Bool isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' isFamFreeTy (TyVarTy _) = True @@ -2217,7 +2318,7 @@ seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 seqType (TyConApp tc tys) = tc `seq` seqTypes tys -seqType (ForAllTy (TvBndr tv _) ty) = seqType (tyVarKind tv) `seq` seqType ty +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty seqType (CastTy ty co) = seqType ty `seq` seqCo co seqType (CoercionTy co) = seqCo co @@ -2278,7 +2379,7 @@ eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 eqVarBndrs env [] [] = Just env eqVarBndrs env (tv1:tvs1) (tv2:tvs2) - | eqTypeX env (tyVarKind tv1) (tyVarKind tv2) + | eqTypeX env (varType tv1) (varType tv2) = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 eqVarBndrs _ _ _= Nothing @@ -2358,8 +2459,8 @@ nonDetCmpTypeX env orig_t1 orig_t2 = go env (TyVarTy tv1) (TyVarTy tv2) = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 - go env (ForAllTy (TvBndr tv1 _) t1) (ForAllTy (TvBndr tv2 _) t2) - = go env (tyVarKind tv1) (tyVarKind tv2) + go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) + = go env (varType tv1) (varType tv2) `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 -- See Note [Equality on AppTys] go env (AppTy s1 t1) ty2 @@ -2437,13 +2538,16 @@ typeKind (FunTy {}) = liftedTypeKind typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (CastTy _ty co) = pSnd $ coercionKind co typeKind (CoercionTy co) = coercionType co -typeKind ty@(ForAllTy {}) = case occCheckExpand tvs k of - Just k' -> k' - Nothing -> pprPanic "typeKind" - (ppr ty $$ ppr k $$ ppr tvs $$ ppr body) - where - (tvs, body) = splitForAllTys ty - k = typeKind body +typeKind ty@(ForAllTy (Bndr tv _) _) + | isTyVar tv -- See Note [Weird typing rule for ForAllTy]. + = case occCheckExpand tvs k of -- We must make sure tv does not occur in kind + Just k' -> k' -- As it is already out of scope! + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr k $$ ppr tvs $$ ppr body) + where + (tvs, body) = splitTyVarForAllTys ty + k = typeKind body +typeKind (ForAllTy {}) = liftedTypeKind typeKind_apps :: HasDebugCallStack => Type -> [Type] -> Kind -- The sole purpose of the function is to accumulate @@ -2524,7 +2628,7 @@ occCheckExpand :: [Var] -> Type -> Maybe Type occCheckExpand vs_to_avoid ty = go (mkVarSet vs_to_avoid, emptyVarEnv) ty where - go :: (VarSet, VarEnv TyVar) -> Type -> Maybe Type + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type -- The VarSet is the set of variables we are trying to avoid -- The VarEnv carries mappings necessary -- because of kind expansion @@ -2541,13 +2645,13 @@ occCheckExpand vs_to_avoid ty go cxt (FunTy ty1 ty2) = do { ty1' <- go cxt ty1 ; ty2' <- go cxt ty2 ; return (mkFunTy ty1' ty2') } - go cxt@(as, env) (ForAllTy (TvBndr tv vis) body_ty) - = do { ki' <- go cxt (tyVarKind tv) - ; let tv' = setTyVarKind tv ki' + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' env' = extendVarEnv env tv tv' as' = as `delVarSet` tv ; body' <- go (as', env') body_ty - ; return (ForAllTy (TvBndr tv' vis) body') } + ; return (ForAllTy (Bndr tv' vis) body') } -- For a type constructor application, first try expanding away the -- offending variable from the arguments. If that doesn't work, next @@ -2564,7 +2668,7 @@ occCheckExpand vs_to_avoid ty ; co' <- go_co cxt co ; return (mkCastTy ty' co') } go cxt (CoercionTy co) = do { co' <- go_co cxt co - ; return (mkCoercionTy co') } + ; return (mkCoercionTy co') } ------------------ go_var cxt v = do { k' <- go cxt (varType v) @@ -2590,7 +2694,7 @@ occCheckExpand vs_to_avoid ty ; return (mkAppCo co' arg') } go_co cxt@(as, env) (ForAllCo tv kind_co body_co) = do { kind_co' <- go_co cxt kind_co - ; let tv' = setTyVarKind tv $ + ; let tv' = setVarType tv $ pFst (coercionKind kind_co') env' = extendVarEnv env tv tv' as' = as `delVarSet` tv @@ -2599,7 +2703,10 @@ occCheckExpand vs_to_avoid ty go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 ; co2' <- go_co cxt co2 ; return (mkFunCo r co1' co2') } - go_co cxt (CoVarCo c) = do { c' <- go_var cxt c + go_co cxt@(as,env) (CoVarCo c) + | c `elemVarSet` as = Nothing + | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') + | otherwise = do { c' <- go_var cxt c ; return (mkCoVarCo c') } go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) ; return (HoleCo (h { ch_co_var = c' })) } @@ -2657,7 +2764,7 @@ tyConsOfType ty go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys go (AppTy a b) = go a `unionUniqSets` go b go (FunTy a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon - go (ForAllTy (TvBndr tv _) ty) = go ty `unionUniqSets` go (tyVarKind tv) + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) go (CastTy ty co) = go ty `unionUniqSets` go_co co go (CoercionTy co) = go_co co @@ -2716,9 +2823,9 @@ splitVisVarsOfType orig_ty = Pair invis_vars vis_vars go (AppTy t1 t2) = go t1 `mappend` go t2 go (TyConApp tc tys) = go_tc tc tys go (FunTy t1 t2) = go t1 `mappend` go t2 - go (ForAllTy (TvBndr tv _) ty) + go (ForAllTy (Bndr tv _) ty) = ((`delVarSet` tv) <$> go ty) `mappend` - (invisible (tyCoVarsOfType $ tyVarKind tv)) + (invisible (tyCoVarsOfType $ varType tv)) go (LitTy {}) = mempty go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) go (CoercionTy co) = invisible $ tyCoVarsOfCo co @@ -2742,7 +2849,7 @@ modifyJoinResTy orig_ar f orig_ty where go 0 ty = f ty go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty - = mkPiTy arg_bndr (go (n-1) res_ty) + = mkTyCoPiTy arg_bndr (go (n-1) res_ty) | otherwise = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs index 24953c9e17..cfa10e4196 100644 --- a/compiler/types/Unify.hs +++ b/compiler/types/Unify.hs @@ -995,8 +995,8 @@ unify_ty env ty1 (AppTy ty2a ty2b) _kco unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () -unify_ty env (ForAllTy (TvBndr tv1 _) ty1) (ForAllTy (TvBndr tv2 _) ty2) kco - = do { unify_ty env (tyVarKind tv1) (tyVarKind tv2) (mkNomReflCo liftedTypeKind) +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) ; let env' = umRnBndr2 env tv1 tv2 ; unify_ty env' ty1 ty2 kco } @@ -1438,9 +1438,10 @@ ty_co_match menv subst (FunTy ty1 ty2) co _lkco _rkco = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos -ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1) +ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) (ForAllCo tv2 kind_co2 co2) lkco rkco + | isTyVar tv1 && isTyVar tv2 = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 ki_ki_co ki_ki_co ; let rn_env0 = me_env menv @@ -1450,6 +1451,29 @@ ty_co_match menv subst (ForAllTy (TvBndr tv1 _) ty1) where ki_ki_co = mkNomReflCo liftedTypeKind +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in Type +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + ty_co_match _ subst (CoercionTy {}) _ _ _ = Just subst -- don't inspect coercions @@ -1523,7 +1547,7 @@ pushRefl co = , mkReflCo r ty1, mkReflCo r ty2 ]) Just (TyConApp tc tys, r) -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) - Just (ForAllTy (TvBndr tv _) ty, r) - -> Just (mkHomoForAllCos_NoRefl [tv] (mkReflCo r ty)) + Just (ForAllTy (Bndr tv _) ty, r) + -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) -- NB: NoRefl variant. Otherwise, we get a loop! _ -> Nothing diff --git a/utils/haddock b/utils/haddock -Subproject 9ef12f3c2f0ef2948e6f4bd38fdfa002c416ab0 +Subproject b66a830b5b1c0166d17f695e7405058650d57ed |