Don't mark closed type family equations as occurrences

Previously, `rnFamInstEqn` would mark the name of the type/data
family used in an equation as an occurrence, regardless of what sort
of family it is. Most of the time, this is the correct thing to do.
The exception is closed type families, whose equations constitute its
definition and therefore should not be marked as occurrences.
Overzealously counting the equations of a closed type family as
occurrences can cause certain warnings to not be emitted, as observed
in #18470.  See `Note [Type family equations and occurrences]` in
`GHC.Rename.Module` for the full story.

This fixes #18470 with a little bit of extra-casing in
`rnFamInstEqn`. To accomplish this, I added an extra
`ClosedTyFamInfo` field to the `NonAssocTyFamEqn` constructor of
`AssocTyFamInfo` and refactored the relevant call sites accordingly
so that this information is propagated to `rnFamInstEqn`.

While I was in town, I moved `wrongTyFamName`, which checks that the
name of a closed type family matches the name in an equation for that
family, from the renamer to the typechecker to avoid the need for an
`ASSERT`. As an added bonus, this lets us simplify the details of
`ClosedTyFamInfo` a bit.

2 files changed, 23 insertions, 8 deletions

diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs
index 5446a756a3..c5fc5bcdbe 100644
--- a/compiler/GHC/Tc/Instance/Class.hs
+++ b/compiler/GHC/Tc/Instance/Class.hs
@@ -67,8 +67,8 @@ data AssocInstInfo
     }
 
 isNotAssociated :: AssocInstInfo -> Bool
-isNotAssociated NotAssociated  = True
-isNotAssociated (InClsInst {}) = False
+isNotAssociated (NotAssociated {}) = True
+isNotAssociated (InClsInst {})     = False
 
 
 {- *******************************************************************
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 013892ee6e..6d33be2e61 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -2833,8 +2833,17 @@ kcTyFamInstEqn tc_fam_tc
            , text "feqn_pats ="  <+> ppr hs_pats ])
           -- this check reports an arity error instead of a kind error; easier for user
        ; let vis_pats = numVisibleArgs hs_pats
+
+       -- First, check if we're dealing with a closed type family equation, and
+       -- if so, ensure that each equation's type constructor is for the right
+       -- type family.  E.g. barf on
+       --    type family F a where { G Int = Bool }
+       ; checkTc (tc_fam_tc_name == eqn_tc_name) $
+         wrongTyFamName tc_fam_tc_name eqn_tc_name
+
        ; checkTc (vis_pats == vis_arity) $
                   wrongNumberOfParmsErr vis_arity
+
        ; discardResult $
          bindImplicitTKBndrs_Q_Tv imp_vars $
          bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $
@@ -2848,7 +2857,7 @@ kcTyFamInstEqn tc_fam_tc
     }
   where
     vis_arity = length (tyConVisibleTyVars tc_fam_tc)
-
+    tc_fam_tc_name = getName tc_fam_tc
 
 --------------------------
 tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
@@ -2858,22 +2867,22 @@ tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn
 
 tcTyFamInstEqn fam_tc mb_clsinfo
     (L loc (HsIB { hsib_ext = imp_vars
-                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name
-                                      , feqn_bndrs  = mb_expl_bndrs
+                 , hsib_body = FamEqn { feqn_bndrs  = mb_expl_bndrs
                                       , feqn_pats   = hs_pats
                                       , feqn_rhs    = hs_rhs_ty }}))
-  = ASSERT( getName fam_tc == eqn_tc_name )
-    setSrcSpan loc $
+  = setSrcSpan loc $
     do { traceTc "tcTyFamInstEqn" $
          vcat [ ppr fam_tc <+> ppr hs_pats
               , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)
               , case mb_clsinfo of
-                  NotAssociated -> empty
+                  NotAssociated {} -> empty
                   InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ]
 
        -- First, check the arity of visible arguments
        -- If we wait until validity checking, we'll get kind errors
        -- below when an arity error will be much easier to understand.
+       -- Note that for closed type families, kcTyFamInstEqn has already
+       -- checked the arity previously.
        ; let vis_arity = length (tyConVisibleTyVars fam_tc)
              vis_pats  = numVisibleArgs hs_pats
        ; checkTc (vis_pats == vis_arity) $
@@ -4919,6 +4928,12 @@ incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>
                    text "for class parameters can lead to incoherence.") $$
                   (text "Use IncoherentInstances to allow this; bad role found")
 
+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 ])
+
 addTyConCtxt :: TyCon -> TcM a -> TcM a
 addTyConCtxt tc = addTyConFlavCtxt name flav
   where