diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-11 23:56:42 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-13 10:57:16 +0100 |
commit | 35c9de7ca053eda472cb446c53bcd2007bfd8394 (patch) | |
tree | 80d86b76d84662ebb810a28a57c544fb3ee043c5 | |
parent | 7afb7adf45216701e4f645676ecc0668f64b424d (diff) | |
download | haskell-35c9de7ca053eda472cb446c53bcd2007bfd8394.tar.gz |
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.
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 3 | ||||
-rw-r--r-- | compiler/typecheck/TcValidity.hs | 27 |
2 files changed, 9 insertions, 21 deletions
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index f07d87706f..7f0023e0f0 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index f137d1efae..b4f2d883be 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |