Fix #16002 by moving a validity check to the renamer

Summary:
The validity check which rejected things like:

```lang=haskell
type family B x where
  A x = x
```

Used to live in the typechecker. But it turns out that this validity
check was //only// being run on closed type families without CUSKs!
This meant that GHC would silently accept something like this:

```lang=haskell
type family B (x :: *) :: * where
  A x = x
```

This patch fixes the issue by moving this validity check to the
renamer, where we can be sure that the check will //always// be run.

Test Plan: make test TEST=T16002

Reviewers: simonpj, bgamari

Reviewed By: simonpj

Subscribers: goldfire, rwbarton, carter

GHC Trac Issues: #16002

Differential Revision: https://phabricator.haskell.org/D5420

7 files changed, 62 insertions, 29 deletions

diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 6027110f36..78444ba126 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -30,7 +30,8 @@ import RnEnv
 import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames
                         , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
                         , checkShadowedRdrNames, warnUnusedTypePatterns
-                        , extendTyVarEnvFVRn, newLocalBndrsRn )
+                        , extendTyVarEnvFVRn, newLocalBndrsRn
+                        , withHsDocContext )
 import RnUnbound        ( mkUnboundName, notInScopeErr )
 import RnNames
 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
@@ -804,18 +805,36 @@ rnTyFamInstDecl :: Maybe (Name, [Name])
                 -> TyFamInstDecl GhcPs
                 -> RnM (TyFamInstDecl GhcRn, FreeVars)
 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
-  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
+  = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls NotClosedTyFam eqn
        ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
 
+-- | Tracks whether we are renaming an equation in a closed type family
+-- equation ('ClosedTyFam') or not ('NotClosedTyFam').
+data ClosedTyFamInfo
+  = NotClosedTyFam
+  | ClosedTyFam (Located RdrName) Name
+                -- The names (RdrName and Name) of the closed type family
+
 rnTyFamInstEqn :: Maybe (Name, [Name])
+               -> ClosedTyFamInfo
                -> TyFamInstEqn GhcPs
                -> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
-                                                     , feqn_rhs   = rhs }})
+rnTyFamInstEqn mb_cls ctf_info
+    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
+                                   , feqn_rhs   = rhs }})
   = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
-       ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
-rnTyFamInstEqn _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
-rnTyFamInstEqn _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
+       ; (eqn'@(HsIB { hsib_body =
+                       FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)
+           <- rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn
+       ; case ctf_info of
+           NotClosedTyFam -> pure ()
+           ClosedTyFam fam_rdr_name fam_name ->
+             checkTc (fam_name == tycon') $
+             withHsDocContext (TyFamilyCtx fam_rdr_name) $
+             wrongTyFamName fam_name tycon'
+       ; pure (eqn', fvs) }
+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"
+rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"
 
 rnTyFamDefltEqn :: Name
                 -> TyFamDefltEqn GhcPs
@@ -1853,7 +1872,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
                ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
                                           injectivity
                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
-       ; (info', fv2) <- rn_info info
+       ; (info', fv2) <- rn_info tycon' info
        ; return (FamilyDecl { fdExt = noExt
                             , fdLName = tycon', fdTyVars = tyvars'
                             , fdFixity = fixity
@@ -1865,14 +1884,18 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
      kvs = extractRdrKindSigVars res_sig
 
      ----------------------
-     rn_info (ClosedTypeFamily (Just eqns))
-       = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
-                                                    -- no class context,
+     rn_info :: Located Name
+             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
+     rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))
+       = do { (eqns', fvs)
+                <- rnList (rnTyFamInstEqn Nothing (ClosedTyFam tycon fam_name))
+                                          -- no class context
+                          eqns
             ; return (ClosedTypeFamily (Just eqns'), fvs) }
-     rn_info (ClosedTypeFamily Nothing)
+     rn_info _ (ClosedTypeFamily Nothing)
        = return (ClosedTypeFamily Nothing, emptyFVs)
-     rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
-     rn_info DataFamily     = return (DataFamily, emptyFVs)
+     rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
+     rn_info _ DataFamily     = return (DataFamily, emptyFVs)
 rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"
 
 rnFamResultSig :: HsDocContext
@@ -2026,6 +2049,12 @@ badAssocRhs ns
                   <+> pprWithCommas (quotes . ppr) ns)
                2 (text "All such variables must be bound on the LHS"))
 
+wrongTyFamName :: Name -> Name -> SDoc
+wrongTyFamName fam_tc_name eqn_tc_name
+  = hang (text "Mismatched type name in type family instance.")
+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name
+               , text "  Actual:" <+> ppr eqn_tc_name ])
+
 -----------------
 rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 71899a1c62..f4ca9932a1 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1733,8 +1733,6 @@ kcTyFamInstEqn tc_fam_tc
            , text "hsib_vars ="  <+> ppr imp_vars
            , text "feqn_bndrs =" <+> ppr mb_expl_bndrs
            , text "feqn_pats ="  <+> ppr hs_pats ])
-       ; checkTc (fam_name == eqn_tc_name)
-                 (wrongTyFamName fam_name eqn_tc_name)
           -- this check reports an arity error instead of a kind error; easier for user
        ; checkTc (hs_pats `lengthIs` vis_arity) $
                   wrongNumberOfParmsErr vis_arity
@@ -1750,7 +1748,6 @@ kcTyFamInstEqn tc_fam_tc
              -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately
     }
   where
-    fam_name  = tyConName tc_fam_tc
     vis_arity = length (tyConVisibleTyVars tc_fam_tc)
 
 kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"
@@ -3813,12 +3810,6 @@ defaultAssocKindErr fam_tc
   = text "Kind mis-match on LHS of default declaration for"
     <+> quotes (ppr fam_tc)
 
-wrongTyFamName :: Name -> Name -> SDoc
-wrongTyFamName fam_tc_name eqn_tc_name
-  = hang (text "Mismatched type name in type family instance.")
-       2 (vcat [ text "Expected:" <+> ppr fam_tc_name
-               , text "  Actual:" <+> ppr eqn_tc_name ])
-
 badRoleAnnot :: Name -> Role -> Role -> SDoc
 badRoleAnnot var annot inferred
   = hang (text "Role mismatch on variable" <+> ppr var <> colon)
diff --git a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
index a889145036..512859753c 100644
--- a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
+++ b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
@@ -1,6 +1,6 @@
 
-Overlap5.hs:8:3:
+Overlap5.hs:8:3: error:
     Mismatched type name in type family instance.
       Expected: F
         Actual: G
-    In the type family declaration for ‘F’
+    In the declaration for type family ‘F’
diff --git a/testsuite/tests/rename/should_fail/T16002.hs b/testsuite/tests/rename/should_fail/T16002.hs
new file mode 100644
index 0000000000..00aadf14dd
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T16002.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module T16002 where
+
+data A
+type family B (x :: *) :: * where
+  A x = x
diff --git a/testsuite/tests/rename/should_fail/T16002.stderr b/testsuite/tests/rename/should_fail/T16002.stderr
new file mode 100644
index 0000000000..98db6f99b6
--- /dev/null
+++ b/testsuite/tests/rename/should_fail/T16002.stderr
@@ -0,0 +1,6 @@
+
+T16002.hs:6:3: error:
+    Mismatched type name in type family instance.
+      Expected: B
+        Actual: A
+    In the declaration for type family ‘B’
diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T
index ba6975483a..56934266d2 100644
--- a/testsuite/tests/rename/should_fail/all.T
+++ b/testsuite/tests/rename/should_fail/all.T
@@ -142,5 +142,6 @@ test('T15607', normal, compile_fail, [''])
 test('T15611a', normal, compile_fail, [''])
 test('T15611b', normal, ghci_script, ['T15611b.script'])
 test('T15828', normal, compile_fail, [''])
+test('T16002', normal, compile_fail, [''])
 
 test('ExplicitForAllRules2', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T11623.stderr b/testsuite/tests/typecheck/should_fail/T11623.stderr
index 0f6253f103..78be1651e2 100644
--- a/testsuite/tests/typecheck/should_fail/T11623.stderr
+++ b/testsuite/tests/typecheck/should_fail/T11623.stderr
@@ -1,6 +1,6 @@
 
 T11623.hs:5:23: error:
-    • Mismatched type name in type family instance.
-        Expected: T
-          Actual: Maybe
-    • In the type family declaration for ‘T’
+    Mismatched type name in type family instance.
+      Expected: T
+        Actual: Maybe
+    In the declaration for type family ‘T’