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

Fix #11648.

We now check that a CUSK is really a CUSK and issue an error if
it isn't. This also involves more solving and zonking in
kcHsTyVarBndrs, which was the outright bug reported in #11648.

Test cases: polykinds/T11648{,b}

This updates the haddock submodule.

[skip ci]
parent e7a8cb14
......@@ -40,6 +40,7 @@ import Id
import Name hiding( isVarOcc, isTcOcc, varName, tcName )
import THNames
import NameEnv
import NameSet
import TcType
import TyCon
import TysWiredIn
......@@ -323,7 +324,8 @@ repFamilyDecl decl@(L loc (FamilyDecl { fdInfo = info,
fdInjectivityAnn = injectivity }))
= do { tc1 <- lookupLOcc tc -- See note [Binders and occurrences]
; let mkHsQTvs :: [LHsTyVarBndr Name] -> LHsQTyVars Name
mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs }
mkHsQTvs tvs = HsQTvs { hsq_implicit = [], hsq_explicit = tvs
, hsq_dependent = emptyNameSet }
resTyVar = case resultSig of
TyVarSig bndr -> mkHsQTvs [bndr]
_ -> mkHsQTvs []
......@@ -471,7 +473,8 @@ repTyFamEqn (L _ (TyFamEqn { tfe_pats = HsIB { hsib_body = tys
, hsib_vars = var_names }
, tfe_rhs = rhs }))
= do { let hs_tvs = HsQTvs { hsq_implicit = var_names
, hsq_explicit = [] } -- Yuk
, hsq_explicit = []
, hsq_dependent = emptyNameSet } -- Yuk
; addTyClTyVarBinds hs_tvs $ \ _ ->
do { tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1
......@@ -484,7 +487,8 @@ repDataFamInstD (DataFamInstDecl { dfid_tycon = tc_name
, dfid_defn = defn })
= do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let hs_tvs = HsQTvs { hsq_implicit = var_names
, hsq_explicit = [] } -- Yuk
, hsq_explicit = []
, hsq_dependent = emptyNameSet } -- Yuk
; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repList typeQTyConName repLTy tys
; repDataDefn tc bndrs (Just tys1) defn } }
......@@ -627,7 +631,8 @@ repC (L _ (ConDeclGADT { con_names = cons
= do { let doc = text "In the constructor for " <+> ppr (head cons)
con_tvs = HsQTvs { hsq_implicit = []
, hsq_explicit = (map (noLoc . UserTyVar . noLoc)
con_vars) ++ tvs }
con_vars) ++ tvs
, hsq_dependent = emptyNameSet }
; addTyVarBinds con_tvs $ \ ex_bndrs -> do
{ (hs_details, gadt_res_ty) <-
updateGadtResult failWithDs doc details res_ty'
......@@ -875,7 +880,8 @@ repHsSigWcType (HsIB { hsib_vars = vars
| (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
= addTyVarBinds (HsQTvs { hsq_implicit = []
, hsq_explicit = map (noLoc . UserTyVar . noLoc) vars ++
explicit_tvs })
explicit_tvs
, hsq_dependent = emptyNameSet })
$ \ th_tvs ->
do { th_ctxt <- repLContext ctxt
; th_ty <- repLTy ty
......@@ -897,7 +903,8 @@ repForall :: HsType Name -> DsM (Core TH.TypeQ)
-- Arg of repForall is always HsForAllTy or HsQualTy
repForall ty
| (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)
= addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs}) $ \bndrs ->
= addTyVarBinds (HsQTvs { hsq_implicit = [], hsq_explicit = tvs
, hsq_dependent = emptyNameSet }) $ \bndrs ->
do { ctxt1 <- repLContext ctxt
; ty1 <- repLTy tau
; repTForall bndrs ctxt1 ty1 }
......
......@@ -210,6 +210,7 @@ cvtDec (DataD ctxt tc tvs ksig constrs derivs)
, dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdDataCusk = PlaceHolder
, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
......@@ -224,6 +225,7 @@ cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
, dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdDataCusk = PlaceHolder
, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs)
......
......@@ -106,7 +106,7 @@ import Util
import SrcLoc
import Bag
import Data.Maybe ( fromMaybe )
import Maybes
import Data.Data hiding (TyCon,Fixity)
{-
......@@ -503,6 +503,7 @@ data TyClDecl name
-- Here the type decl for 'f' includes 'a'
-- in its tcdTyVars
, tcdDataDefn :: HsDataDefn name
, tcdDataCusk :: PostRn name Bool -- ^ does this have a CUSK?
, tcdFVs :: PostRn name NameSet }
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
......@@ -632,7 +633,7 @@ countTyClDecls decls
-- | Does this declaration have a complete, user-supplied kind signature?
-- See Note [Complete user-supplied kind signatures]
hsDeclHasCusk :: TyClDecl Name -> Bool
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk fam_decl
hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) = famDeclHasCusk Nothing fam_decl
hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
= hsTvbAllKinded tyvars && rhs_annotated rhs
where
......@@ -640,7 +641,7 @@ hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })
HsParTy lty -> rhs_annotated lty
HsKindSig {} -> True
_ -> False
hsDeclHasCusk (DataDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
hsDeclHasCusk (DataDecl { tcdDataCusk = cusk }) = cusk
hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl
......@@ -837,12 +838,15 @@ data FamilyInfo name
deriving instance (DataId name) => Data (FamilyInfo name)
-- | Does this family declaration have a complete, user-supplied kind signature?
famDeclHasCusk :: FamilyDecl name -> Bool
famDeclHasCusk (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
famDeclHasCusk :: Maybe Bool
-- ^ if associated, does the enclosing class have a CUSK?
-> FamilyDecl name -> Bool
famDeclHasCusk _ (FamilyDecl { fdInfo = ClosedTypeFamily _
, fdTyVars = tyvars
, fdResultSig = L _ resultSig })
= hsTvbAllKinded tyvars && hasReturnKindSignature resultSig
famDeclHasCusk _ = True -- all open families have CUSKs!
famDeclHasCusk mb_class_cusk _ = mb_class_cusk `orElse` True
-- all un-associated open families have CUSKs!
-- | Does this family declaration have user-supplied return kind signature?
hasReturnKindSignature :: FamilyResultSig a -> Bool
......@@ -879,6 +883,10 @@ variables and its return type are annotated.
- An open type family always has a CUSK -- unannotated type variables (and
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.
-}
instance (OutputableBndr name) => Outputable (FamilyDecl name) where
......@@ -1133,7 +1141,7 @@ pprConDecl (ConDeclH98 { con_name = L _ con
<+> pprConDeclFields (unLoc fields)
tvs = case mtvs of
Nothing -> []
Just (HsQTvs _ tvs) -> tvs
Just (HsQTvs { hsq_explicit = tvs }) -> tvs
cxt = fromMaybe (noLoc []) mcxt
......
......@@ -74,6 +74,7 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
import Id ( Id )
import Name( Name )
import RdrName ( RdrName )
import NameSet ( NameSet, emptyNameSet )
import DataCon( HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..) )
import TysPrim( funTyConName )
......@@ -246,23 +247,27 @@ data LHsQTyVars name -- See Note [HsType binders]
= HsQTvs { hsq_implicit :: PostRn name [Name] -- implicit (dependent) variables
, hsq_explicit :: [LHsTyVarBndr name] -- explicit variables
-- See Note [HsForAllTy tyvar binders]
, hsq_dependent :: PostRn name NameSet
-- which explicit vars are dependent
-- See Note [Dependent LHsQTyVars] in TcHsType
}
deriving( Typeable )
deriving instance (DataId name) => Data (LHsQTyVars name)
mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName
mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs }
mkHsQTvs tvs = HsQTvs { hsq_implicit = PlaceHolder, hsq_explicit = tvs
, hsq_dependent = PlaceHolder }
hsQTvExplicit :: LHsQTyVars name -> [LHsTyVarBndr name]
hsQTvExplicit = hsq_explicit
emptyLHsQTvs :: LHsQTyVars Name
emptyLHsQTvs = HsQTvs [] []
emptyLHsQTvs = HsQTvs [] [] emptyNameSet
isEmptyLHsQTvs :: LHsQTyVars Name -> Bool
isEmptyLHsQTvs (HsQTvs [] []) = True
isEmptyLHsQTvs _ = False
isEmptyLHsQTvs (HsQTvs [] [] _) = True
isEmptyLHsQTvs _ = False
------------------------------------------------
-- HsImplicitBndrs
......
......@@ -176,6 +176,7 @@ mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_deriv
; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv
; return (L loc (DataDecl { tcdLName = tc, tcdTyVars = tyvars,
tcdDataDefn = defn,
tcdDataCusk = PlaceHolder,
tcdFVs = placeHolderNames })) }
mkDataDefn :: NewOrData
......
......@@ -816,7 +816,7 @@ rnDataFamInstDecl :: Maybe (Name, [Name])
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
, dfid_pats = pats
, dfid_defn = defn })
= do { (tycon', pats', defn', fvs) <-
= do { (tycon', pats', (defn', _), fvs) <-
rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
; return (DataFamInstDecl { dfid_tycon = tycon'
, dfid_pats = pats'
......@@ -1264,11 +1264,17 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
; kvs <- extractDataDefnKindVars defn
; let doc = TyDataCtx tycon
; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' ->
do { (defn', fvs) <- rnDataDefn doc defn
; return ((tyvars', defn'), fvs) }
; ((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) }
-- See Note [Complete user-supplied kind signatures] in HsDecls
; typeintype <- xoptM LangExt.TypeInType
; let cusk = hsTvbAllKinded tyvars' &&
(not typeintype || no_kvs)
; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
, tcdDataDefn = defn', tcdDataCusk = cusk
, tcdFVs = fvs }, fvs) }
rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
......@@ -1391,14 +1397,23 @@ orphanRoleAnnotErr (L loc decl)
quotes (ppr $ roleAnnotDeclName decl) <+>
text "is declared.")
rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
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
rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context, dd_cons = condecls
, dd_kindSig = sig, dd_derivs = derivs })
, dd_kindSig = m_sig, dd_derivs = derivs })
= do { checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta doc)
; (sig', sig_fvs) <- rnLHsMaybeKind doc sig
; (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)
; (context', fvs1) <- rnContext doc context
; (derivs', fvs3) <- rn_derivs derivs
......@@ -1414,10 +1429,11 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
con_fvs `plusFV` sig_fvs
; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context', dd_kindSig = sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
; return (( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
, dd_ctxt = context', dd_kindSig = m_sig'
, dd_cons = condecls'
, dd_derivs = derivs' }
, cusk )
, all_fvs )
}
where
......@@ -1504,7 +1520,7 @@ rnFamResultSig doc kv_names (TyVarSig tvbndr)
(mkNameSet kv_names) emptyNameSet
-- use of emptyNameSet here avoids
-- redundant duplicate errors
tvbndr $ \ _ tvbndr' ->
tvbndr $ \ _ _ tvbndr' ->
return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
-- Note [Renaming injectivity annotation]
......
......@@ -10,7 +10,7 @@
module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsMaybeKind,
rnHsKind, rnLHsKind,
rnHsSigType, rnHsWcType,
rnHsSigWcType, rnHsSigWcTypeScoped,
rnLHsInstType,
......@@ -144,7 +144,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'
......@@ -426,14 +426,6 @@ rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName)
-> RnM (Maybe (LHsKind Name), FreeVars)
rnLHsMaybeKind _ Nothing
= return (Nothing, emptyFVs)
rnLHsMaybeKind doc (Just kind)
= do { (kind', fvs) <- rnLHsKind doc kind
; return (Just kind', fvs) }
--------------
rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnTyKiContext env (L loc cxt)
......@@ -458,7 +450,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) } }
......@@ -853,9 +845,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 ->
\ rn_kvs rn_bndrs dep_var_set ->
thing_inside (HsQTvs { hsq_implicit = rn_kvs
, hsq_explicit = rn_bndrs }) }
, hsq_explicit = rn_bndrs
, hsq_dependent = dep_var_set }) }
bindLHsTyVarBndrs :: forall a b.
HsDocContext
......@@ -867,11 +860,14 @@ bindLHsTyVarBndrs :: forall a b.
-> [LHsTyVarBndr RdrName] -- ... these user-written tyvars
-> ( [Name] -- all kv names
-> [LHsTyVarBndr Name]
-> NameSet -- which names, from the preceding list,
-- are used dependently within that list
-- See Note [Dependent LHsQTyVars] in TcHsType
-> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
= do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
; go [] [] emptyNameSet emptyNameSet tv_bndrs }
; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }
where
tv_names_w_loc = map hsLTyVarLocName tv_bndrs
......@@ -879,29 +875,38 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
-> [LHsTyVarBndr Name] -- already renamed (in reverse order)
-> NameSet -- kind vars already in scope (for dup checking)
-> NameSet -- type vars already in scope (for dup checking)
-> NameSet -- (all) variables used dependently
-> [LHsTyVarBndr RdrName] -- still to be renamed, scoped
-> RnM (b, FreeVars)
go rn_kvs rn_tvs kv_names tv_names (tv_bndr : tv_bndrs)
go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)
= bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
\ kv_nms tv_bndr' ->
\ kv_nms used_dependently tv_bndr' ->
do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)
(tv_bndr' : rn_tvs)
(kv_names `extendNameSetList` kv_nms)
(tv_names `extendNameSet` hsLTyVarName tv_bndr')
(dep_vars `unionNameSet` used_dependently)
tv_bndrs
; warn_unused tv_bndr' fvs
; return (b, fvs) }
go rn_kvs rn_tvs _kv_names tv_names []
go rn_kvs rn_tvs _kv_names tv_names dep_vars []
= -- still need to deal with the kv_bndrs passed in originally
bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms ->
bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->
do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
all_rn_tvs = reverse rn_tvs
; env <- getLocalRdrEnv
; let all_dep_vars = dep_vars `unionNameSet` others
exp_dep_vars -- variables in all_rn_tvs that are in dep_vars
= mkNameSet [ name
| v <- all_rn_tvs
, let name = hsLTyVarName v
, name `elemNameSet` all_dep_vars ]
; traceRn (text "bindHsTyVars" <+> (ppr env $$
ppr all_rn_kvs $$
ppr all_rn_tvs))
; thing_inside all_rn_kvs all_rn_tvs }
ppr all_rn_tvs $$
ppr exp_dep_vars))
; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars }
warn_unused tv_bndr fvs = case mb_in_doc of
Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
......@@ -912,8 +917,9 @@ bindLHsTyVarBndr :: HsDocContext
-> NameSet -- kind vars already in scope
-> NameSet -- type vars already in scope
-> LHsTyVarBndr RdrName
-> ([Name] -> LHsTyVarBndr Name -> RnM (b, FreeVars))
-> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars))
-- passed the newly-bound implicitly-declared kind vars,
-- any other names used in a kind
-- and the renamed LHsTyVarBndr
-> RnM (b, FreeVars)
bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
......@@ -922,7 +928,7 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
do { check_dup loc rdr
; nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
thing_inside [] (L loc (UserTyVar (L lv nm))) }
thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
do { check_dup lv rdr
......@@ -932,11 +938,12 @@ bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
-- deal with kind vars in the user-written kind
; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
; bindImplicitKvs doc mb_assoc free_kvs tv_names $ \ kv_nms ->
; bindImplicitKvs doc mb_assoc free_kvs tv_names $
\ new_kv_nms other_kv_nms ->
do { (kind', fvs1) <- rnLHsKind doc kind
; tv_nm <- newTyVarNameRn mb_assoc lrdr
; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
thing_inside kv_nms
thing_inside new_kv_nms other_kv_nms
(L loc (KindedTyVar (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }}
where
......@@ -964,9 +971,11 @@ bindImplicitKvs :: HsDocContext
-- intent to bind is inferred
-> NameSet -- ^ *type* variables, for type/kind
-- misuse check for -XNoTypeInType
-> ([Name] -> RnM (b, FreeVars)) -- ^ passed new kv_names
-> ([Name] -> NameSet -> RnM (b, FreeVars))
-- ^ passed new kv_names, and any other names used in a kind
-> RnM (b, FreeVars)
bindImplicitKvs _ _ [] _ thing_inside = thing_inside []
bindImplicitKvs _ _ [] _ thing_inside
= thing_inside [] emptyNameSet
bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
= do { rdr_env <- getLocalRdrEnv
; let part_kvs lrdr@(L loc kv_rdr)
......@@ -987,7 +996,7 @@ bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
-- bind the vars and move on
; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
; bindLocalNamesFV kv_nms $
thing_inside kv_nms }
thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }
where
-- check to see if the variables free in a kind are bound as type
-- variables. Assume -XNoTypeInType.
......
This diff is collapsed.
......@@ -1309,7 +1309,7 @@ zonkTcTyCoVarBndr :: TcTyCoVar -> TcM TcTyCoVar
-- unification variables.
zonkTcTyCoVarBndr tyvar
-- can't use isCoVar, because it looks at a TyCon. Argh.
= ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), ppr tyvar ) do
= ASSERT2( isImmutableTyVar tyvar || (not $ isTyVar tyvar), pprTvBndr tyvar )
updateTyVarKindM zonkTcType tyvar
-- | Zonk a TyBinder
......
......@@ -285,7 +285,8 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
-- Step 1: Bind kind variables for non-synonyms
let (syn_decls, non_syn_decls) = partition (isSynDecl . unLoc) decls
; initial_kinds <- getInitialKinds non_syn_decls
; traceTc "kcTyClGroup: initial kinds" (ppr initial_kinds)
; traceTc "kcTyClGroup: initial kinds" $
vcat (map pp_initial_kind initial_kinds)
-- Step 2: Set initial envt, kind-check the synonyms
; lcl_env <- tcExtendKindEnv2 initial_kinds $
......@@ -302,7 +303,7 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
-- Now we have to kind generalize the flexis
; res <- concatMapM (generaliseTCD (tcl_env lcl_env)) decls
; traceTc "kcTyClGroup result" (ppr res)
; traceTc "kcTyClGroup result" (vcat (map pp_res res))
; return res }
where
......@@ -316,14 +317,15 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
kc_res_kind = tyConResKind tc
; kvs <- kindGeneralize (mkForAllTys kc_binders kc_res_kind)
; (kc_binders', kc_res_kind') <- zonkTcKindToKind kc_binders kc_res_kind
; let kc_binders'' = anonymiseTyBinders kc_binders' kc_res_kind'
-- Make sure kc_kind' has the final, zonked kind variables
; traceTc "Generalise kind" $
vcat [ ppr name, ppr kc_binders, ppr kc_res_kind
, ppr kvs, ppr kc_binders', ppr kc_res_kind' ]
, ppr kvs, ppr kc_binders'', ppr kc_res_kind' ]
; return (mkTcTyCon name
(map (mkNamedBinder Invisible) kvs ++ kc_binders')
(map (mkNamedBinder Invisible) kvs ++ kc_binders'')
kc_res_kind'
(mightBeUnsaturatedTyCon tc)) }
......@@ -348,6 +350,13 @@ kcTyClGroup (TyClGroup { group_tyclds = decls })
generaliseFamDecl kind_env (FamilyDecl { fdLName = L _ name })
= generalise kind_env name
pp_initial_kind (name, ATcTyCon tc)
= ppr name <+> dcolon <+> ppr (tyConKind tc)
pp_initial_kind pair
= ppr pair
pp_res tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
mkTcTyConPair :: TcTyCon -> (Name, TcTyThing)
-- Makes a binding to put in the local envt, binding
-- a name to a TcTyCon
......@@ -393,20 +402,22 @@ getInitialKind :: TyClDecl Name
getInitialKind decl@(ClassDecl { tcdLName = L _ name, tcdTyVars = ktvs, tcdATs = ats })
= do { (cl_binders, cl_kind, inner_prs) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ ->
do { inner_prs <- getFamDeclInitialKinds ats
kcHsTyVarBndrs cusk False True ktvs $
do { inner_prs <- getFamDeclInitialKinds (Just cusk) ats
; return (constraintKind, inner_prs) }
; cl_binders <- mapM zonkTcTyBinder cl_binders
; cl_kind <- zonkTcType cl_kind
; let main_pr = mkTcTyConPair (mkTcTyCon name cl_binders cl_kind True)
; return (main_pr : inner_prs) }
where
cusk = hsDeclHasCusk decl
getInitialKind decl@(DataDecl { tcdLName = L _ name
, tcdTyVars = ktvs
, tcdDataDefn = HsDataDefn { dd_kindSig = m_sig
, dd_cons = cons } })
= do { (decl_binders, decl_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) ktvs $ \_ _ ->
kcHsTyVarBndrs (hsDeclHasCusk decl) False True ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Nothing -> return liftedTypeKind
......@@ -419,31 +430,33 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
; return (main_pr : inner_prs) }
getInitialKind (FamDecl { tcdFam = decl })
= getFamDeclInitialKind decl
= getFamDeclInitialKind Nothing decl
getInitialKind decl@(SynDecl {})
= pprPanic "getInitialKind" (ppr decl)
---------------------------------
getFamDeclInitialKinds :: [LFamilyDecl Name] -> TcM [(Name, TcTyThing)]
getFamDeclInitialKinds decls
getFamDeclInitialKinds :: Maybe Bool -- if assoc., CUSKness of assoc. class
-> [LFamilyDecl Name] -> TcM [(Name, TcTyThing)]
getFamDeclInitialKinds mb_cusk decls
= tcExtendKindEnv2 [ (n, APromotionErr TyConPE)
| L _ (FamilyDecl { fdLName = L _ n }) <- decls] $
concatMapM (addLocM getFamDeclInitialKind) decls
concatMapM (addLocM (getFamDeclInitialKind mb_cusk)) decls
getFamDeclInitialKind :: FamilyDecl Name
getFamDeclInitialKind :: Maybe Bool -- if assoc., CUSKness of assoc. class
-> FamilyDecl Name
-> TcM [(Name, TcTyThing)]
getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
, fdTyVars = ktvs
, fdResultSig = L _ resultSig
, fdInfo = info })
getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
, fdTyVars = ktvs
, fdResultSig = L _ resultSig
, fdInfo = info })
= do { (fam_binders, fam_kind, _) <-
kcHsTyVarBndrs (famDeclHasCusk decl) ktvs $ \_ _ ->
kcHsTyVarBndrs cusk open True ktvs $
do { res_k <- case resultSig of
KindSig ki -> tcLHsKind ki
TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki
_ -- open type families have * return kind by default
| famDeclHasCusk decl -> return liftedTypeKind
| open -> return liftedTypeKind
-- closed type families have their return kind inferred
-- by default
| otherwise -> newMetaKindVar
......@@ -452,10 +465,11 @@ getFamDeclInitialKind decl@(FamilyDecl { fdLName = L _ name
; fam_kind <- zonkTcType fam_kind
; return [ mkTcTyConPair (mkTcTyCon name fam_binders fam_kind unsat) ] }
where
unsat = case info of
DataFamily -> True
OpenTypeFamily -> False
ClosedTypeFamily _ -> False
cusk = famDeclHasCusk mb_cusk decl
(open, unsat) = case info of
DataFamily -> (True, True)
OpenTypeFamily -> (True, False)
ClosedTypeFamily _ -> (False, False)
----------------
kcSynDecls :: [SCC (LTyClDecl Name)]
......@@ -463,6 +477,7 @@ kcSynDecls :: [SCC (LTyClDecl Name)]
kcSynDecls [] = getLclEnv
kcSynDecls (group : groups)
= do { tc <- kcSynDecl1 group
; traceTc "kcSynDecl" (ppr tc <+> dcolon <+> ppr (tyConKind tc))
; tcExtendKindEnv2 [ mkTcTyConPair tc ] $
kcSynDecls groups }
......@@ -479,7 +494,7 @@ kcSynDecl decl@(SynDecl { tcdTyVars = hs_tvs, tcdLName = L _ name
-- Returns a possibly-unzonked kind
= tcAddDeclCtxt decl $
do { (syn_binders, syn_kind, _) <-
kcHsTyVarBndrs (hsDeclHasCusk decl) hs_tvs $ \_ _ ->
kcHsTyVarBndrs (hsDeclHasCusk decl) False True hs_tvs $
do { traceTc "kcd1" (ppr name <+> brackets (ppr hs_tvs))
; (_, rhs_kind) <- tcLHsType rhs
; traceTc "kcd2" (ppr name)
......@@ -548,8 +563,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs
-- the 'False' says that the existentials don't have a CUSK, as the
-- concept doesn't really apply here. We just need to bring the variables
-- into scope.
do { _ <- kcHsTyVarBndrs False ((fromMaybe (HsQTvs mempty []) ex_tvs)) $
\ _ _ ->
do { _ <- kcHsTyVarBndrs False False False ((fromMaybe emptyLHsQTvs ex_tvs)) $
do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt)
; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details)
; return (panic "kcConDecl", ()) }
......@@ -2075,11 +2089,28 @@ checkValidTyConTyVars tc
= text "NB: Implicitly declared kind variables are put first."
| otherwise
= empty
; checkValidTelescope (pprTvBndrs vis_tvs) stripped_tvs extra }
; checkValidTelescope (pprTvBndrs vis_tvs) stripped_tvs extra
`and_if_that_doesn't_error`
-- This triggers on test case dependent/should_fail/InferDependency
-- It reports errors around Note [Dependent LHsQTyVars] in TcHsType
addErr (vcat [ text "Invalid declaration for" <+>
quotes (ppr tc) <> semi <+> text "you must explicitly"
, text "declare which variables are dependent on which others."
, hang (text "Inferred variable kinds:")
2 (vcat (map pp_tv stripped_tvs)) ]) }
where
tvs = tyConTyVars tc
duplicate_vars = sizeVarSet (mkVarSet tvs) < length tvs
pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
-- only run try_second if the first reports no errors
and_if_that_doesn't_error :: TcM () -> TcM () -> TcM ()
try_first `and_if_that_doesn't_error` try_second
= recoverM (return ()) $
do { checkNoErrs try_first
; try_second }
-------------------------------
checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()
checkValidDataCon dflags existential_ok tc con
......
......@@ -87,6 +87,7 @@ module TcType (
orphNamesOfTypes, orphNamesOfCoCon,
getDFunTyKey,
evVarPred_maybe, evVarPred,
anonymiseTyBinders,
---------------------------------
-- Predicate types
......@@ -222,6 +223,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Control.Monad (liftM, ap)
import Data.Functor.Identity
import Data.List ( mapAccumR )
{-
************************************************************************
......@@ -2358,3 +2360,28 @@ sizeType = go
sizeTypes :: [Type] -> TypeSize
sizeTypes tys = sum (map sizeType tys)
{-
************************************************************************
* *
Binders
* *
************************************************************************
-}
-- | Given a list of binders and a type they bind in, turn any
-- superfluous Named binders into Anon ones.