Move the constraint-kind validity check
authorSimon Peyton Jones <simonpj@microsoft.com>
Sat, 11 Jun 2016 22:56:42 +0000 (23:56 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Mon, 13 Jun 2016 09:57:16 +0000 (10:57 +0100)
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.

compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcValidity.hs

index f07d877..7f0023e 100644 (file)
@@ -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
index f137d1e..b4f2d88 100644 (file)
@@ -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]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~