Commit b1084fd7 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Fix #11811.

Previously, I had forgotten to omit variables already in scope
from the TypeInType CUSK check. Simple enough to fix.

Test case: typecheck/should_compile/T11811
parent f4446c5b
......@@ -887,6 +887,8 @@ return type) default to *.
- Additionally, if -XTypeInType is on, then a data definition with a top-level
:: must explicitly bind all kind variables to the right of the ::.
See test dependent/should_compile/KindLevels, which requires this case.
(Naturally, any kind variable mentioned before the :: should not be bound
after it.)
-}
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
......
......@@ -52,6 +52,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Arrow ( first )
import Data.List ( sortBy )
import Maybes( orElse, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
......@@ -801,7 +802,7 @@ rnTyFamDefltEqn :: Name
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = tyvars
, tfe_rhs = rhs })
= bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' ->
= bindHsQTyVars ctx Nothing (Just cls) [] tyvars $ \ tyvars' _ ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
; return (TyFamEqn { tfe_tycon = tycon'
......@@ -1251,7 +1252,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
; let doc = TySynCtx tycon
; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $
\ tyvars' ->
\ tyvars' _ ->
do { (rhs', fvs) <- rnTySyn doc rhs
; return ((tyvars', rhs'), fvs) }
; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
......@@ -1265,9 +1266,11 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
; let doc = TyDataCtx tycon
; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
; ((tyvars', defn', no_kvs), fvs)
<- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' ->
do { ((defn', no_kvs), fvs) <- rnDataDefn doc defn
; return ((tyvars', defn', no_kvs), fvs) }
<- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' dep_vars ->
do { ((defn', kind_sig_fvs), fvs) <- rnDataDefn doc defn
; let sig_tvs = filterNameSet isTyVarName kind_sig_fvs
unbound_sig_tvs = sig_tvs `minusNameSet` dep_vars
; return ((tyvars', defn', isEmptyNameSet unbound_sig_tvs), fvs) }
-- See Note [Complete user-supplied kind signatures] in HsDecls
; typeintype <- xoptM LangExt.TypeInType
; let cusk = hsTvbAllKinded tyvars' &&
......@@ -1287,7 +1290,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats'), stuff_fvs)
<- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' -> do
<- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
-- Checks for distinct tyvars
{ (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds fds
......@@ -1398,22 +1401,18 @@ orphanRoleAnnotErr (L loc decl)
text "is declared.")
rnDataDefn :: HsDocContext -> HsDataDefn RdrName
-> RnM ((HsDataDefn Name, Bool), FreeVars)
-- the Bool is True if the DataDefn is consistent with
-- having a CUSK. See Note [Complete user-supplied kind signatures]
-- in HsDecls
-> RnM ((HsDataDefn Name, NameSet), FreeVars)
-- the NameSet includes all Names free in the kind signature
-- See Note [Complete user-supplied kind signatures]
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context, dd_cons = condecls
, dd_kindSig = m_sig, dd_derivs = derivs })
= do { checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta doc)
; (m_sig', cusk, sig_fvs) <- case m_sig of
Just sig -> do { fkvs <- freeKiTyVarsAllVars <$>
extractHsTyRdrTyVars sig
; (sig', fvs) <- rnLHsKind doc sig
; return (Just sig', null fkvs, fvs) }
Nothing -> return (Nothing, True, emptyFVs)
; (m_sig', sig_fvs) <- case m_sig of
Just sig -> first Just <$> rnLHsKind doc sig
Nothing -> return (Nothing, emptyFVs)
; (context', fvs1) <- rnContext doc context
; (derivs', fvs3) <- rn_derivs derivs
......@@ -1433,7 +1432,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context', dd_kindSig = m_sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
, cusk )
, sig_fvs )
, all_fvs )
}
where
......@@ -1464,7 +1463,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
; kvs <- extractRdrKindSigVars res_sig
; ((tyvars', res_sig', injectivity'), fv1) <-
bindHsQTyVars doc Nothing mb_cls kvs tyvars $
\ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) ->
\ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) _ ->
do { let rn_sig = rnFamResultSig doc rn_kvs
; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
......@@ -1728,7 +1727,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs
; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details)
; bindHsQTyVars doc (Just $ inHsDocContext doc) Nothing kvs qtvs' $
\new_tyvars -> do
\new_tyvars _ -> do
{ (new_context, fvs1) <- case mcxt of
Nothing -> return (Nothing,emptyFVs)
Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt
......
......@@ -25,6 +25,7 @@ module RnTypes (
-- Binding related stuff
bindLHsTyVarBndr,
bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
extractFilteredRdrTyVars,
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
extractRdrKindSigVars, extractDataDefnKindVars,
......@@ -104,7 +105,7 @@ rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs
rn_hs_sig_wc_type no_implicit_if_forall ctxt
(HsIB { hsib_body = wc_ty }) thing_inside
= do { let hs_ty = hswc_body wc_ty
; free_vars <- extract_filtered_rdr_ty_vars hs_ty
; free_vars <- extractFilteredRdrTyVars hs_ty
; (free_vars', nwc_rdrs) <- partition_nwcs free_vars
; rnImplicitBndrs no_implicit_if_forall free_vars' hs_ty $ \ vars ->
do { rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' ->
......@@ -113,7 +114,7 @@ rn_hs_sig_wc_type no_implicit_if_forall ctxt
rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
rnHsWcType ctxt wc_ty@(HsWC { hswc_body = hs_ty })
= do { free_vars <- extract_filtered_rdr_ty_vars hs_ty
= do { free_vars <- extractFilteredRdrTyVars hs_ty
; (_, nwc_rdrs) <- partition_nwcs free_vars
; rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' ->
return (wc_ty', emptyFVs) }
......@@ -148,7 +149,7 @@ rnWcSigTy :: RnTyKiEnv -> LHsType RdrName
-- wildcard. Some code duplication, but no big deal.
rnWcSigTy env (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
= bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
Nothing [] tvs $ \ _ tvs' _ ->
Nothing [] tvs $ \ _ tvs' _ _ ->
do { (hs_tau', fvs) <- rnWcSigTy env hs_tau
; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
awcs_bndrs = collectAnonWildCardsBndrs tvs'
......@@ -197,13 +198,13 @@ rnWcSigContext env (L loc hs_ctxt)
rn_top_constraint = rnLHsTyKi (env { rtke_what = RnTopConstraint })
-- | extract_filtered finds free type and kind variables in a type,
-- | Finds free type and kind variables in a type,
-- without duplicates, and
-- without variables that are already in scope in LocalRdrEnv
-- NB: this includes named wildcards, which look like perfectly
-- ordinary type variables at this point
extract_filtered_rdr_ty_vars :: LHsType RdrName -> RnM FreeKiTyVars
extract_filtered_rdr_ty_vars hs_ty
extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars
extractFilteredRdrTyVars hs_ty
= do { rdr_env <- getLocalRdrEnv
; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
......@@ -248,7 +249,7 @@ rnHsSigType :: HsDocContext -> LHsSigType RdrName
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType ctx (HsIB { hsib_body = hs_ty })
= do { vars <- extract_filtered_rdr_ty_vars hs_ty
= do { vars <- extractFilteredRdrTyVars hs_ty
; rnImplicitBndrs True vars hs_ty $ \ vars ->
do { (body', fvs) <- rnLHsType ctx hs_ty
; return (HsIB { hsib_vars = vars
......@@ -454,7 +455,7 @@ rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)
rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau })
= do { checkTypeInType env ty
; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
Nothing [] tyvars $ \ _ tyvars' _ ->
Nothing [] tyvars $ \ _ tyvars' _ _ ->
do { (tau', fvs) <- rnLHsTyKi env tau
; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' }
, fvs) } }
......@@ -840,7 +841,10 @@ bindHsQTyVars :: forall a b.
-> [Located RdrName] -- Kind variables from scope, in l-to-r
-- order, but not from ...
-> (LHsQTyVars RdrName) -- ... these user-written tyvars
-> (LHsQTyVars Name -> RnM (b, FreeVars))
-> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars))
-- also returns all names used in kind signatures, for the
-- TypeInType clause of Note [Complete user-supplied kind
-- signatures] in HsDecls
-> RnM (b, FreeVars)
-- (a) Bring kind variables into scope
-- both (i) passed in (kv_bndrs)
......@@ -849,10 +853,10 @@ bindHsQTyVars :: forall a b.
bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
= do { bindLHsTyVarBndrs doc mb_in_doc
mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
\ rn_kvs rn_bndrs dep_var_set ->
\ rn_kvs rn_bndrs dep_var_set all_dep_vars ->
thing_inside (HsQTvs { hsq_implicit = rn_kvs
, hsq_explicit = rn_bndrs
, hsq_dependent = dep_var_set }) }
, hsq_dependent = dep_var_set }) all_dep_vars }
bindLHsTyVarBndrs :: forall a b.
HsDocContext
......@@ -867,6 +871,7 @@ bindLHsTyVarBndrs :: forall a b.
-> NameSet -- which names, from the preceding list,
-- are used dependently within that list
-- See Note [Dependent LHsQTyVars] in TcHsType
-> NameSet -- all names used in kind signatures
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
......@@ -910,7 +915,7 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
ppr all_rn_kvs $$
ppr all_rn_tvs $$
ppr exp_dep_vars))
; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars }
; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars all_dep_vars }
warn_unused tv_bndr fvs = case mb_in_doc of
Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
......
{-# LANGUAGE TypeInType, GADTs #-}
module T11811 where
import Data.Kind
data Test (a :: x) (b :: x) :: x -> *
where K :: Test Int Bool Double
......@@ -511,3 +511,4 @@ test('T11401', normal, compile, [''])
test('T11699', normal, compile, [''])
test('T11512', normal, compile, [''])
test('T11754', normal, compile, [''])
test('T11811', normal, compile, [''])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment