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

Better error messages during sort checking of kind signatures

Fixes Trac #6039, where we have a bogus kind signature
   data T (a :: j k) = MkT
parent 33ff4981
......@@ -1345,9 +1345,8 @@ tc_hs_kind k = panic ("tc_hs_kind: " ++ showPpr k)
-- Special case for kind application
tc_app :: HsKind Name -> [LHsKind Name] -> TcM Kind
tc_app (HsAppTy ki1 ki2) kis = tc_app (unLoc ki1) (ki2:kis)
tc_app (HsTyVar tc) kis =
do arg_kis <- mapM tc_lhs_kind kis
tc_var_app tc arg_kis
tc_app (HsTyVar tc) kis = do { arg_kis <- mapM tc_lhs_kind kis
; tc_var_app tc arg_kis }
tc_app ki _ = failWithTc (quotes (ppr ki) <+>
ptext (sLit "is not a kind constructor"))
......@@ -1365,36 +1364,40 @@ tc_var_app name arg_kis
_ -> panic "tc_var_app 1" }
-- General case
tc_var_app name arg_kis = do
(_errs, mb_thing) <- tryTc (tcLookup name)
case mb_thing of
Just (AGlobal (ATyCon tc))
| isAlgTyCon tc || isTupleTyCon tc -> do
data_kinds <- xoptM Opt_DataKinds
unless data_kinds $ addErr (dataKindsErr name)
case isPromotableTyCon tc of
Just n | n == length arg_kis ->
return (mkTyConApp (buildPromotedTyCon tc) arg_kis)
Just _ -> err tc "is not fully applied"
Nothing -> err tc "is not promotable"
-- A lexically scoped kind variable
Just (ATyVar _ kind_var) -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
-- It is in scope, but not what we expected
Just thing -> wrongThingErr "promoted type" thing name
-- It is not in scope, but it passed the renamer: staging error
Nothing -> -- ASSERT2 ( isTyConName name, ppr name )
do env <- getLclEnv
traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env))
failWithTc (ptext (sLit "Promoted kind") <+>
quotes (ppr name) <+>
ptext (sLit "used in a mutually recursive group"))
tc_var_app name arg_kis
= do { (_errs, mb_thing) <- tryTc (tcLookup name)
; case mb_thing of
Just (AGlobal (ATyCon tc))
| isAlgTyCon tc || isTupleTyCon tc
-> do { data_kinds <- xoptM Opt_DataKinds
; unless data_kinds $ addErr (dataKindsErr name)
; case isPromotableTyCon tc of
Just n | n == length arg_kis ->
return (mkTyConApp (buildPromotedTyCon tc) arg_kis)
Just _ -> err tc "is not fully applied"
Nothing -> err tc "is not promotable" }
-- A lexically scoped kind variable
-- Kind variables always have kind BOX, so cannot be applied to anything
Just (ATyVar _ kind_var)
| null arg_kis -> return (mkAppTys (mkTyVarTy kind_var) arg_kis)
| otherwise -> failWithTc (ptext (sLit "Kind variable") <+> quotes (ppr name)
<+> ptext (sLit "cannot appear in a function position"))
-- It is in scope, but not what we expected
Just thing -> wrongThingErr "promoted type" thing name
-- It is not in scope, but it passed the renamer: staging error
Nothing
-> -- ASSERT2 ( isTyConName name, ppr name )
do { env <- getLclEnv
; traceTc "tc_var_app" (ppr name $$ ppr (tcl_env env))
; failWithTc (ptext (sLit "Promoted kind") <+>
quotes (ppr name) <+>
ptext (sLit "used in a mutually recursive group")) } }
where
err tc msg = failWithTc (quotes (ppr tc) <+> ptext (sLit "of kind")
<+> quotes (ppr (tyConKind tc)) <+> ptext (sLit msg))
\end{code}
%************************************************************************
......
......@@ -1234,6 +1234,7 @@ checkValidTyCon tc
= case synTyConRhs tc of
SynFamilyTyCon {} -> return ()
SynonymTyCon ty -> checkValidType syn_ctxt ty
| otherwise
= do { -- Check the context on the data decl
; traceTc "cvtc1" (ppr tc)
......@@ -1309,6 +1310,7 @@ checkValidDataCon tc con
; let tc_tvs = tyConTyVars tc
res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
actual_res_ty = dataConOrigResTy con
; traceTc "checkValidDataCon" (ppr con $$ ppr tc $$ ppr tc_tvs $$ ppr res_ty_tmpl)
; checkTc (isJust (tcMatchTy (mkVarSet tc_tvs)
res_ty_tmpl
actual_res_ty))
......
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