Commit c80920d2 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Do zonking in tcLHsKindSig

Trac #13879 showed that there was a missing zonk in tcLHsKind.

I also renamed it to tcLHsKindSig, for consistency with type signatures
There's a commment to explain why the zonk is needed.
parent 4bdac331
......@@ -37,7 +37,7 @@ module TcHsType (
kindGeneralize,
-- Sort-checking kinds
tcLHsKind,
tcLHsKindSig,
-- Pattern type signatures
tcHsPatSigType, tcPatSig, funAppCtxt
......@@ -1428,7 +1428,7 @@ kcHsTyVarBndrs name unsat cusk open_fam all_kind_vars
; return tv_pair }
kc_hs_tv (KindedTyVar (L _ name) lhs_kind)
= do { kind <- tcLHsKind lhs_kind
= do { kind <- tcLHsKindSig lhs_kind
; tcHsTyVarName (Just kind) name }
report_non_cusk_tvs all_tvs
......@@ -1545,7 +1545,7 @@ tcHsTyVarBndr new_tv (UserTyVar (L _ name))
; new_tv name kind }
tcHsTyVarBndr new_tv (KindedTyVar (L _ name) kind)
= do { kind <- tcLHsKind kind
= do { kind <- tcLHsKindSig kind
; new_tv name kind }
newWildTyVar :: Name -> TcM TcTyVar
......@@ -2031,12 +2031,20 @@ unifyKinds act_kinds
* *
************************************************************************
tcLHsKind converts a user-written kind to an internal, sort-checked kind.
tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.
It does sort checking and desugaring at the same time, in one single pass.
-}
tcLHsKind :: LHsKind GhcRn -> TcM Kind
tcLHsKind = tc_lhs_kind kindLevelMode
tcLHsKindSig :: LHsKind GhcRn -> TcM Kind
tcLHsKindSig hs_kind
= do { kind <- tc_lhs_kind kindLevelMode hs_kind
; zonkTcType kind }
-- This zonk is very important in the case of higher rank kinds
-- E.g. Trac #13879 f :: forall (p :: forall z (y::z). <blah>).
-- <more blah>
-- When instanting p's kind at occurrences of p in <more blah>
-- it's crucial that the kind we instantiate is fully zonked,
-- else we may fail to substitute properly
tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind
tc_lhs_kind mode k
......
......@@ -493,7 +493,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name
= do { (tycon, _) <-
kcHsTyVarBndrs name True (hsDeclHasCusk decl) False True ktvs $
do { res_k <- case m_sig of
Just ksig -> tcLHsKind ksig
Just ksig -> tcLHsKindSig ksig
Nothing -> return liftedTypeKind
; return (res_k, ()) }
; return (mkTcTyConEnv tycon) }
......@@ -508,7 +508,7 @@ getInitialKind decl@(SynDecl { tcdLName = L _ name
False {- not open -} True ktvs $
do { res_k <- case kind_annotation rhs of
Nothing -> newMetaKindVar
Just ksig -> tcLHsKind ksig
Just ksig -> tcLHsKindSig ksig
; return (res_k, ()) }
; return (mkTcTyConEnv tycon) }
where
......@@ -536,8 +536,8 @@ getFamDeclInitialKind mb_cusk decl@(FamilyDecl { fdLName = L _ name
= do { (tycon, _) <-
kcHsTyVarBndrs name unsat cusk open True ktvs $
do { res_k <- case resultSig of
KindSig ki -> tcLHsKind ki
TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKind ki
KindSig ki -> tcLHsKindSig ki
TyVarSig (L _ (KindedTyVar _ ki)) -> tcLHsKindSig ki
_ -- open type families have * return kind by default
| open -> return liftedTypeKind
-- closed type families have their return kind inferred
......@@ -1191,7 +1191,7 @@ kcDataDefn fam_name (HsIB { hsib_body = pats })
; discardResult $
case mb_kind of
Nothing -> unifyKind (Just hs_ty_pats) res_k liftedTypeKind
Just k -> do { k' <- tcLHsKind k
Just k -> do { k' <- tcLHsKindSig k
; unifyKind (Just hs_ty_pats) res_k k' } }
where
hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats
......
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