Commit 35c9de7c authored by Simon Peyton Jones's avatar Simon Peyton Jones

Move the constraint-kind validity check

For type synonyms, we need to check that if the RHS has
kind Constraint, then we have -XConstraintKinds.  For
some reason this was done in checkValidType, but it makes
more sense to do it in checkValidTyCon.

I can't remember quite why I made this change; maybe it fixes
a Trac ticket, but if so I forget which.  But it's a modest
improvement anyway.
parent 7afb7adf
......@@ -2113,7 +2113,8 @@ checkValidTyCon tc
-> checkValidClass cl
| Just syn_rhs <- synTyConRhs_maybe tc
-> checkValidType syn_ctxt syn_rhs
-> do { checkValidType syn_ctxt syn_rhs
; checkTySynRhs syn_ctxt syn_rhs }
| Just fam_flav <- famTyConFlav_maybe tc
-> case fam_flav of
......
......@@ -10,7 +10,7 @@ module TcValidity (
ContextKind(..), expectedKindInCtxt,
checkValidTheta, checkValidFamPats,
checkValidInstance, validDerivPred,
checkInstTermination,
checkInstTermination, checkTySynRhs,
ClsInstInfo, checkValidCoAxiom, checkValidCoAxBranch,
checkValidTyFamEqn,
arityErr, badATErr,
......@@ -355,11 +355,6 @@ checkValidType ctxt ty
-- Check the internal validity of the type itself
; check_type env ctxt rank ty
-- Check that the thing has kind Type, and is lifted if necessary.
-- Do this *after* check_type, because we can't usefully take
-- the kind of an ill-formed type such as (a~Int)
; check_kind env ctxt ty
; checkUserTypeError ty
-- Check for ambiguous types. See Note [When to call checkAmbiguity]
......@@ -375,23 +370,18 @@ checkValidMonoType ty
= do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)
; check_type env SigmaCtxt MustBeMonoType ty }
check_kind :: TidyEnv -> UserTypeCtxt -> TcType -> TcM ()
-- Check that the type's kind is acceptable for the context
check_kind env ctxt ty
| TySynCtxt {} <- ctxt
, returnsConstraintKind actual_kind
checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()
checkTySynRhs ctxt ty
| returnsConstraintKind actual_kind
= do { ck <- xoptM LangExt.ConstraintKinds
; if ck
then when (isConstraintKind actual_kind)
(do { dflags <- getDynFlags
; check_pred_ty env dflags ctxt ty })
else addErrTcM (constraintSynErr env actual_kind) }
; check_pred_ty emptyTidyEnv dflags ctxt ty })
else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }
| otherwise
= case expectedKindInCtxt ctxt of
TheKind k -> checkTcM (tcEqType actual_kind k) (kindErr env actual_kind)
OpenKind -> checkTcM (classifiesTypeWithValues actual_kind) (kindErr env actual_kind)
AnythingKind -> return ()
= return ()
where
actual_kind = typeKind ty
......@@ -653,9 +643,6 @@ forAllEscapeErr env ty tau_kind
ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)
ubxArgTyErr env ty = (env, sep [text "Illegal unboxed tuple type as function argument:", ppr_tidy env ty])
kindErr :: TidyEnv -> Kind -> (TidyEnv, SDoc)
kindErr env kind = (env, sep [text "Expecting an ordinary type, but found a type of kind", ppr_tidy env kind])
{-
Note [Liberal type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
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