Report family instance orphans correctly

This fixes the fact that we were not reporting orphan family instances
at all. The fix here is easy, but touches a bit of code. I refactored
the code to be much more similar to the way that class instances are done:

   - Add a fi_orphan field to FamInst, like the is_orphan field in ClsInst
   - Make newFamInst initialise this field, just like newClsInst
   - And make newFamInst report a warning for an orphan, just like newClsInst
   - I moved newFamInst from GHC.Tc.Instance.Family to GHC.Tc.Utils.Instantiate,
     just like newClsInst.
   - I added mkLocalFamInst to FamInstEnv, just like mkLocalClsInst in InstEnv
   - TcRnOrphanInstance and SuggestFixOrphanInstance are now parametrised
     over class instances vs type/data family instances.

Fixes #19773

2 files changed, 52 insertions, 16 deletions

diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index a51377c2d0..0a0389d71b 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -11,7 +11,7 @@ module GHC.Core.FamInstEnv (
         FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
         famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,
         pprFamInst, pprFamInsts, orphNamesOfFamInst,
-        mkImportedFamInst,
+        mkImportedFamInst, mkLocalFamInst,
 
         FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
         unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList,
@@ -38,6 +38,7 @@ module GHC.Core.FamInstEnv (
 
 import GHC.Prelude
 
+import GHC.Core( IsOrphan, chooseOrphanAnchor )
 import GHC.Core.Unify
 import GHC.Core.Type as Type
 import GHC.Core.TyCo.Rep
@@ -126,6 +127,8 @@ data FamInst  -- See Note [FamInsts and CoAxioms]
             -- in GHC.Core.Coercion.Axiom
 
             , fi_rhs :: Type         --   the RHS, with its freshened vars
+
+            , fi_orphan :: IsOrphan
             }
 
 data FamFlavor
@@ -254,6 +257,36 @@ pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax
 pprFamInsts :: [FamInst] -> SDoc
 pprFamInsts finsts = vcat (map pprFamInst finsts)
 
+{- *********************************************************************
+*                                                                      *
+                 Making FamInsts
+*                                                                      *
+********************************************************************* -}
+
+mkLocalFamInst :: FamFlavor -> CoAxiom Unbranched
+               -> [TyVar] -> [CoVar] -> [Type] -> Type
+               -> FamInst
+mkLocalFamInst flavor axiom tvs cvs lhs rhs
+  = FamInst { fi_fam      = fam_tc_name
+            , fi_flavor   = flavor
+            , fi_tcs      = roughMatchTcs lhs
+            , fi_tvs      = tvs
+            , fi_cvs      = cvs
+            , fi_tys      = lhs
+            , fi_rhs      = rhs
+            , fi_axiom    = axiom
+            , fi_orphan   = chooseOrphanAnchor orph_names }
+  where
+    mod = assert (isExternalName (coAxiomName axiom)) $
+          nameModule (coAxiomName axiom)
+    is_local name = nameIsLocalOrFrom mod name
+
+    orph_names = filterNameSet is_local $
+                 orphNamesOfAxiomLHS axiom `extendNameSet` fam_tc_name
+
+    fam_tc_name = tyConName (coAxiomTyCon axiom)
+
+
 {-
 Note [Lazy axiom match]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -277,8 +310,9 @@ also.
 mkImportedFamInst :: Name               -- Name of the family
                   -> [RoughMatchTc]     -- Rough match info
                   -> CoAxiom Unbranched -- Axiom introduced
+                  -> IsOrphan
                   -> FamInst            -- Resulting family instance
-mkImportedFamInst fam mb_tcs axiom
+mkImportedFamInst fam mb_tcs axiom orphan
   = FamInst {
       fi_fam    = fam,
       fi_tcs    = mb_tcs,
@@ -287,7 +321,8 @@ mkImportedFamInst fam mb_tcs axiom
       fi_tys    = tys,
       fi_rhs    = rhs,
       fi_axiom  = axiom,
-      fi_flavor = flavor }
+      fi_flavor = flavor,
+      fi_orphan = orphan }
   where
      -- See Note [Lazy axiom match]
      ~(CoAxBranch { cab_lhs = tys
diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs
index f06f12e89a..90664d46e2 100644
--- a/compiler/GHC/Core/InstEnv.hs
+++ b/compiler/GHC/Core/InstEnv.hs
@@ -14,7 +14,7 @@ module GHC.Core.InstEnv (
         PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
         ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
-        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
+        instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,
         instanceDFunId, updateClsInstDFuns, updateClsInstDFun,
         fuzzyClsInstCmp, orphNamesOfClsInst,
 
@@ -40,6 +40,7 @@ import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )
 import GHC.Core.RoughMap
 import GHC.Core.Class
 import GHC.Core.Unify
+import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )
 
 import GHC.Unit.Module.Env
 import GHC.Unit.Types
@@ -255,13 +256,13 @@ instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type])
 -- Decomposes the DFunId
 instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec))
 
-mkLocalInstance :: DFunId -> OverlapFlag
-                -> [TyVar] -> Class -> [Type]
-                -> ClsInst
+mkLocalClsInst :: DFunId -> OverlapFlag
+               -> [TyVar] -> Class -> [Type]
+               -> ClsInst
 -- Used for local instances, where we can safely pull on the DFunId.
 -- Consider using newClsInst instead; this will also warn if
 -- the instance is an orphan.
-mkLocalInstance dfun oflag tvs cls tys
+mkLocalClsInst dfun oflag tvs cls tys
   = ClsInst { is_flag = oflag, is_dfun = dfun
             , is_tvs = tvs
             , is_dfun_name = dfun_name
@@ -298,18 +299,18 @@ mkLocalInstance dfun oflag tvs cls tys
 
     choose_one nss = chooseOrphanAnchor (unionNameSets nss)
 
-mkImportedInstance :: Name           -- ^ the name of the class
-                   -> [RoughMatchTc] -- ^ the rough match signature of the instance
-                   -> Name           -- ^ the 'Name' of the dictionary binding
-                   -> DFunId         -- ^ the 'Id' of the dictionary.
-                   -> OverlapFlag    -- ^ may this instance overlap?
-                   -> IsOrphan       -- ^ is this instance an orphan?
-                   -> ClsInst
+mkImportedClsInst :: Name           -- ^ the name of the class
+                  -> [RoughMatchTc] -- ^ the rough match signature of the instance
+                  -> Name           -- ^ the 'Name' of the dictionary binding
+                  -> DFunId         -- ^ the 'Id' of the dictionary.
+                  -> OverlapFlag    -- ^ may this instance overlap?
+                  -> IsOrphan       -- ^ is this instance an orphan?
+                  -> ClsInst
 -- Used for imported instances, where we get the rough-match stuff
 -- from the interface file
 -- The bound tyvars of the dfun are guaranteed fresh, because
 -- the dfun has been typechecked out of the same interface file
-mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan
+mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan
   = ClsInst { is_flag = oflag, is_dfun = dfun
             , is_tvs = tvs, is_tys = tys
             , is_dfun_name = dfun_name