Don't mark closed type family equations as occurrenceswip/T18470

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.

11 files changed, 147 insertions, 71 deletions

diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 15775b8cf2..b6c8a9b801 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -424,11 +424,11 @@ patchCCallTarget unit callTarget =
 
 rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
-  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi
+  = do { (tfi', fvs) <- rnTyFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) tfi
        ; return (TyFamInstD { tfid_ext = noExtField, tfid_inst = tfi' }, fvs) }
 
 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
-  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi
+  = do { (dfi', fvs) <- rnDataFamInstDecl (NonAssocTyFamEqn NotClosedTyFam) dfi
        ; return (DataFamInstD { dfid_ext = noExtField, dfid_inst = dfi' }, fvs) }
 
 rnSrcInstDecl (ClsInstD { cid_inst = cid })
@@ -760,8 +760,12 @@ rnFamInstEqn doc atfi rhs_kvars
              all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'
        ; warnUnusedTypePatterns all_nms nms_used
 
-       ; let all_fvs = (rhs_fvs `plusFV` pat_fvs) `addOneFV` unLoc tycon'
-            -- type instance => use, hence addOneFV
+       ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs
+             -- See Note [Type family equations and occurrences]
+             all_fvs = case atfi of
+                         NonAssocTyFamEqn ClosedTyFam
+                           -> eqn_fvs
+                         _ -> eqn_fvs `addOneFV` unLoc tycon'
 
        ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]
                       , hsib_body
@@ -776,14 +780,14 @@ rnFamInstEqn doc atfi rhs_kvars
     -- The parent class, if we are dealing with an associated type family
     -- instance.
     mb_cls = case atfi of
-      NonAssocTyFamEqn     -> Nothing
+      NonAssocTyFamEqn _   -> Nothing
       AssocTyFamDeflt cls  -> Just cls
       AssocTyFamInst cls _ -> Just cls
 
     -- The type variables from the instance head, if we are dealing with an
     -- associated type family instance.
     inst_tvs = case atfi of
-      NonAssocTyFamEqn          -> []
+      NonAssocTyFamEqn _        -> []
       AssocTyFamDeflt _         -> []
       AssocTyFamInst _ inst_tvs -> inst_tvs
 
@@ -806,48 +810,62 @@ rnTyFamInstDecl :: AssocTyFamInfo
                 -> TyFamInstDecl GhcPs
                 -> RnM (TyFamInstDecl GhcRn, FreeVars)
 rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })
-  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn
+  = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn
        ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
 
 -- | Tracks whether we are renaming:
 --
 -- 1. A type family equation that is not associated
---    with a parent type class ('NonAssocTyFamEqn')
+--    with a parent type class ('NonAssocTyFamEqn'). Examples:
 --
--- 2. An associated type family default declaration ('AssocTyFamDeflt')
+--    @
+--    type family F a
+--    type instance F Int = Bool  -- NonAssocTyFamEqn NotClosed
 --
--- 3. An associated type family instance declaration ('AssocTyFamInst')
+--    type family G a where
+--       G Int = Bool             -- NonAssocTyFamEqn Closed
+--    @
+--
+-- 2. An associated type family default declaration ('AssocTyFamDeflt').
+--    Example:
+--
+--    @
+--    class C a where
+--      type A a
+--      type instance A a = a -> a  -- AssocTyFamDeflt C
+--    @
+--
+-- 3. An associated type family instance declaration ('AssocTyFamInst').
+--    Example:
+--
+--    @
+--    instance C a => C [a] where
+--      type A [a] = Bool  -- AssocTyFamInst C [a]
+--    @
 data AssocTyFamInfo
   = NonAssocTyFamEqn
-  | AssocTyFamDeflt Name   -- Name of the parent class
-  | AssocTyFamInst  Name   -- Name of the parent class
-                    [Name] -- Names of the tyvars of the parent instance decl
+      ClosedTyFamInfo -- Is this a closed type family?
+  | AssocTyFamDeflt
+      Name            -- Name of the parent class
+  | AssocTyFamInst
+      Name            -- Name of the parent class
+      [Name]          -- Names of the tyvars of the parent instance decl
 
 -- | 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
+  | ClosedTyFam
 
 rnTyFamInstEqn :: AssocTyFamInfo
-               -> ClosedTyFamInfo
                -> TyFamInstEqn GhcPs
                -> RnM (TyFamInstEqn GhcRn, FreeVars)
-rnTyFamInstEqn atfi ctf_info
+rnTyFamInstEqn atfi
     eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
                                    , feqn_rhs   = rhs }})
-  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
-       ; (eqn'@(HsIB { hsib_body =
-                       FamEqn { feqn_tycon = L _ tycon' }}), fvs)
-           <- rnFamInstEqn (TySynCtx tycon) atfi 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) }
+  = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn
+  where
+    rhs_kvs = extractHsTyRdrTyVarsKindVars rhs
 
 rnTyFamDefltDecl :: Name
                  -> TyFamDefltDecl GhcPs
@@ -995,6 +1013,51 @@ was previously bound by the `instance C (Maybe a)` part. (see #16116).
 
 In each case, the function which detects improperly bound variables on the RHS
 is GHC.Tc.Validity.checkValidFamPats.
+
+Note [Type family equations and occurrences]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In most data/type family equations, the type family name used in the equation
+is treated as an occurrence. For example:
+
+  module A where
+    type family F a
+
+  module B () where
+    import B (F)
+    type instance F Int = Bool
+
+We do not want to warn about `F` being unused in the module `B`, as the
+instance constitutes a use site for `F`. The exception to this rule is closed
+type families, whose equations constitute a definition, not occurrences. For
+example:
+
+  module C () where
+    type family CF a where
+      CF Char = Float
+
+Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is
+defined but not used (#18470).
+
+GHC accomplishes this in rnFamInstEqn when determining the set of free
+variables to return at the end. If renaming a data family or open type family
+equation, we add the name of the type family constructor to the set of returned
+free variables to ensure that the name is marked as an occurrence. If renaming
+a closed type family equation, we avoid adding the type family constructor name
+to the free variables. This is quite simple, but it is not a perfect solution.
+Consider this example:
+
+  module X () where
+    type family F a where
+      F Int = Bool
+      F Double = F Int
+
+At present, GHC will treat any use of a type family constructor on the RHS of a
+type family equation as an occurrence. Since `F` is used on the RHS of the
+second equation of `F`, it is treated as an occurrence, causing `F` not to be
+warned about. This is not ideal, since `F` isn't exported—it really /should/
+cause a warning to be emitted. There is some discussion in #10089/#12920 about
+how this limitation might be overcome, but until then, we stick to the
+simplistic solution above, as it fixes the egregious bug in #18470.
 -}
 
 
@@ -1947,7 +2010,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 tycon' info
+       ; (info', fv2) <- rn_info info
        ; return (FamilyDecl { fdExt = noExtField
                             , fdLName = tycon', fdTyVars = tyvars'
                             , fdFixity = fixity
@@ -1959,18 +2022,16 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
      kvs = extractRdrKindSigVars res_sig
 
      ----------------------
-     rn_info :: Located Name
-             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
-     rn_info (L _ fam_name) (ClosedTypeFamily (Just eqns))
+     rn_info :: FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)
+     rn_info (ClosedTypeFamily (Just eqns))
        = do { (eqns', fvs)
-                <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))
+                <- rnList (rnTyFamInstEqn (NonAssocTyFamEqn ClosedTyFam)) eqns
                                           -- 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)
 
 rnFamResultSig :: HsDocContext
                -> FamilyResultSig GhcPs
@@ -2114,13 +2175,6 @@ are no data constructors we allow h98_style = True
 *                                                      *
 ***************************************************** -}
 
----------------
-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/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
diff --git a/testsuite/tests/indexed-types/should_fail/Overlap5.stderr b/testsuite/tests/indexed-types/should_fail/Overlap5.stderr
index 512859753c..f67549104b 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: error:
-    Mismatched type name in type family instance.
-      Expected: F
-        Actual: G
-    In the declaration for type family ‘F’
+    • Mismatched type name in type family instance.
+        Expected: F
+          Actual: G
+    • In the type family declaration for ‘F’
diff --git a/testsuite/tests/rename/should_fail/T16002.stderr b/testsuite/tests/rename/should_fail/T16002.stderr
index 98db6f99b6..91279ffeeb 100644
--- a/testsuite/tests/rename/should_fail/T16002.stderr
+++ b/testsuite/tests/rename/should_fail/T16002.stderr
@@ -1,6 +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’
+    • Mismatched type name in type family instance.
+        Expected: B
+          Actual: A
+    • In the type family declaration for ‘B’
diff --git a/testsuite/tests/th/T15362.hs b/testsuite/tests/th/T15362.hs
index 183f887252..1bab4d776c 100644
--- a/testsuite/tests/th/T15362.hs
+++ b/testsuite/tests/th/T15362.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds #-}
+{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds, TypeFamilies #-}
 
 module T15362 where
 
diff --git a/testsuite/tests/th/T15362.stderr b/testsuite/tests/th/T15362.stderr
index 0ec2dd8e48..b63cb3553e 100644
--- a/testsuite/tests/th/T15362.stderr
+++ b/testsuite/tests/th/T15362.stderr
@@ -1,10 +1,6 @@
 
-T15362.hs:8:10: error:
+T15362.hs:7:2: error:
     • Mismatched type name in type family instance.
         Expected: +
           Actual: Maybe
-      In the declaration for type family ‘+’
-    • In the Template Haskell quotation
-        [d| type family a + b where
-              Maybe Zero b = b
-              Succ a + b = Succ (a + b) |]
+    • In the type family declaration for ‘+’
diff --git a/testsuite/tests/typecheck/should_compile/T18470.hs b/testsuite/tests/typecheck/should_compile/T18470.hs
new file mode 100644
index 0000000000..618c1433ff
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T18470.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wunused-top-binds #-}
+
+module T18470 () where
+
+type family Closed x where
+  Closed Int = Bool
diff --git a/testsuite/tests/typecheck/should_compile/T18470.stderr b/testsuite/tests/typecheck/should_compile/T18470.stderr
new file mode 100644
index 0000000000..ffefb020d3
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T18470.stderr
@@ -0,0 +1,3 @@
+
+T18470.hs:6:1: warning: [-Wunused-top-binds (in -Wextra, -Wunused-binds)]
+    Defined but not used: type constructor or class ‘Closed’
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 82a30f50f4..d720891df5 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -717,3 +717,4 @@ test('T17775-viewpats-b', normal, compile_fail, [''])
 test('T17775-viewpats-c', normal, compile_fail, [''])
 test('T17775-viewpats-d', normal, compile_fail, [''])
 test('T18412', normal, compile, [''])
+test('T18470', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T11623.stderr b/testsuite/tests/typecheck/should_fail/T11623.stderr
index 78be1651e2..0f6253f103 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 declaration for type family ‘T’
+    • Mismatched type name in type family instance.
+        Expected: T
+          Actual: Maybe
+    • In the type family declaration for ‘T’