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

28 files changed, 269 insertions, 150 deletions

diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs
index 92b34ffc21..37ece67857 100644
--- a/compiler/GHC/Core.hs
+++ b/compiler/GHC/Core.hs
@@ -1077,7 +1077,7 @@ has two major consequences
 
 Orphan-hood is computed
   * For class instances:
-    when we make a ClsInst in GHC.Core.InstEnv.mkLocalInstance
+    when we make a ClsInst in GHC.Core.InstEnv.mkLocalClsInst
       (because it is needed during instance lookup)
     See Note [When exactly is an instance decl an orphan?]
         in GHC.Core.InstEnv
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
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index b6865e8e60..9684c20ad5 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -42,7 +42,6 @@ import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
 import GHC.Core.ConLike
 import GHC.Core.DataCon
-import GHC.Core.FVs ( orphNamesOfAxiomLHS )
 import GHC.Core.Type
 import GHC.Core.Multiplicity
 import GHC.Core.InstEnv
@@ -723,30 +722,19 @@ instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag
                  , ifInstCls  = cls_name
                  , ifInstTys  = ifaceRoughMatchTcs $ tail rough_tcs
                    -- N.B. Drop the class name from the rough match template
-                   --      It is put back by GHC.Core.InstEnv.mkImportedInstance
+                   --      It is put back by GHC.Core.InstEnv.mkImportedClsInst
                  , ifInstOrph = orph }
 
 --------------------------
 famInstToIfaceFamInst :: FamInst -> IfaceFamInst
-famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
-                                 fi_fam      = fam,
-                                 fi_tcs      = rough_tcs })
+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom
+                               , fi_fam      = fam
+                               , fi_tcs      = rough_tcs
+                               , fi_orphan   = orphan })
   = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom
                  , ifFamInstFam      = fam
                  , ifFamInstTys      = ifaceRoughMatchTcs rough_tcs
-                 , ifFamInstOrph     = orph }
-  where
-    fam_decl = tyConName $ coAxiomTyCon axiom
-    mod = assert (isExternalName (coAxiomName axiom)) $
-          nameModule (coAxiomName axiom)
-    is_local name = nameIsLocalOrFrom mod name
-
-    lhs_names = filterNameSet is_local (orphNamesOfAxiomLHS axiom)
-
-    orph | is_local fam_decl
-         = NotOrphan (nameOccName fam_decl)
-         | otherwise
-         = chooseOrphanAnchor lhs_names
+                 , ifFamInstOrph     = orphan }
 
 ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon]
 ifaceRoughMatchTcs tcs = map do_rough tcs
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index fa714448ac..206d4ab4dd 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1244,17 +1244,18 @@ tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag
   = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $
                     fmap tyThingId (tcIfaceImplicit dfun_name)
        ; let mb_tcs' = map tcRoughTyCon mb_tcs
-       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }
+       ; return (mkImportedClsInst cls mb_tcs' dfun_name dfun oflag orph) }
 
 tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs
-                             , ifFamInstAxiom = axiom_name } )
+                             , ifFamInstAxiom = axiom_name
+                             , ifFamInstOrph = orphan } )
     = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $
                      tcIfaceCoAxiom axiom_name
              -- will panic if branched, but that's OK
          ; let axiom'' = toUnbranchedAxiom axiom'
                mb_tcs' = map tcRoughTyCon mb_tcs
-         ; return (mkImportedFamInst fam mb_tcs' axiom'') }
+         ; return (mkImportedFamInst fam mb_tcs' axiom'' orphan) }
 
 {-
 ************************************************************************
diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index d4e4b87db8..7ada3093e5 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -44,52 +44,55 @@ module GHC.Tc.Deriv.Generate (
 
 import GHC.Prelude
 
-import GHC.Tc.Utils.Monad
 import GHC.Hs
-import GHC.Types.FieldLabel
+
+import GHC.Tc.Utils.Monad
+import GHC.Tc.Utils.Instantiate( newFamInst )
+import GHC.Tc.Utils.Env
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Utils.Zonk
+import GHC.Tc.Validity ( checkValidCoAxBranch )
+
+import GHC.Core.DataCon
+import GHC.Core.FamInstEnv
+import GHC.Core.TyCon
+import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
+import GHC.Core.Type
+import GHC.Core.Class
+
 import GHC.Types.Name.Reader
 import GHC.Types.Basic
 import GHC.Types.Fixity
-import GHC.Core.DataCon
 import GHC.Types.Name
 import GHC.Types.SourceText
+import GHC.Types.Id.Make ( coerceId )
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.FM ( lookupUFM, listToUFM )
+import GHC.Types.Var.Env
+import GHC.Types.Var
 
-import GHC.Tc.Instance.Family
-import GHC.Core.FamInstEnv
 import GHC.Builtin.Names
 import GHC.Builtin.Names.TH
-import GHC.Types.Id.Make ( coerceId )
 import GHC.Builtin.PrimOps
 import GHC.Builtin.PrimOps.Ids (primOpId)
-import GHC.Types.SrcLoc
-import GHC.Core.TyCon
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.TcType
-import GHC.Tc.Utils.Zonk
-import GHC.Tc.Validity ( checkValidCoAxBranch )
-import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Types
-import GHC.Core.Type
-import GHC.Core.Class
 
-import GHC.Types.Unique.FM ( lookupUFM, listToUFM )
-import GHC.Types.Var.Env
 import GHC.Utils.Misc
-import GHC.Types.Var
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Utils.Lexeme
+
 import GHC.Data.FastString
 import GHC.Data.Pair
 import GHC.Data.Bag
+import GHC.Data.Maybe ( expectJust )
+import GHC.Unit.Module
 
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import Data.List  ( find, partition, intersperse )
-import GHC.Data.Maybe ( expectJust )
-import GHC.Unit.Module
 
 -- | A declarative description of an auxiliary binding that should be
 -- generated. See @Note [Auxiliary binders]@ for a more detailed description
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 2b1bbb2bf2..509282d3e5 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -28,7 +28,9 @@ import GHC.Tc.Utils.TcType
 import GHC.Tc.Deriv.Generate
 import GHC.Tc.Deriv.Functor
 import GHC.Tc.Errors.Types
-import GHC.Tc.Instance.Family
+import GHC.Tc.Utils.Instantiate( newFamInst )
+import GHC.Tc.Utils.Env
+import GHC.Tc.Utils.Monad
 
 import GHC.Core.Type
 import GHC.Core.DataCon
@@ -45,23 +47,24 @@ import GHC.Types.Name.Reader
 import GHC.Types.SourceText
 import GHC.Types.Fixity
 import GHC.Types.Basic
+import GHC.Types.SrcLoc
+import GHC.Types.Var.Env
+import GHC.Types.Var.Set (elemVarSet)
+
 import GHC.Builtin.Types.Prim
 import GHC.Builtin.Types
 import GHC.Builtin.Names
-import GHC.Tc.Utils.Env
-import GHC.Tc.Utils.Monad
-import GHC.Driver.Session
+
 import GHC.Utils.Error( Validity'(..), andValid )
-import GHC.Types.SrcLoc
-import GHC.Data.Bag
-import GHC.Types.Var.Env
-import GHC.Types.Var.Set (elemVarSet)
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import GHC.Data.FastString
 import GHC.Utils.Misc
 
+import GHC.Driver.Session
+import GHC.Data.Bag
+import GHC.Data.FastString
+
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import Control.Monad (mplus)
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index ffe1d1c196..3d6dfab2a4 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -34,7 +34,7 @@ import GHC.Core.Class
 import GHC.Core.DataCon
 import GHC.Core.Coercion.Axiom (coAxiomTyCon, coAxiomSingleBranch)
 import GHC.Core.ConLike
-import GHC.Core.FamInstEnv ( famInstAxiom )
+import GHC.Core.FamInstEnv ( FamInst(..), famInstAxiom, pprFamInst )
 import GHC.Core.InstEnv
 import GHC.Core.TyCo.Rep (Type(..))
 import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,
@@ -42,6 +42,7 @@ import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,
 import GHC.Core.PatSyn ( patSynName, pprPatSynType )
 import GHC.Core.Predicate
 import GHC.Core.Type
+import GHC.Core.FVs( orphNamesOfTypes )
 
 import GHC.Driver.Flags
 import GHC.Driver.Backend
@@ -417,11 +418,14 @@ instance Diagnostic TcRnMessage where
               sep [ text "The Monomorphism Restriction applies to the binding"
                   <> plural bindings
                   , text "for" <+> pp_bndrs ]
-    TcRnOrphanInstance inst
+    TcRnOrphanInstance (Left cls_inst)
       -> mkSimpleDecorated $
-           hsep [ text "Orphan instance:"
-                , pprInstanceHdr inst
-                ]
+           hang (text "Orphan class instance:")
+              2 (pprInstanceHdr cls_inst)
+    TcRnOrphanInstance (Right fam_inst)
+      -> mkSimpleDecorated $
+           hang (text "Orphan family instance:")
+              2 (pprFamInst fam_inst)
     TcRnFunDepConflict unit_state sorted
       -> let herald = text "Functional dependencies conflict between instance declarations:"
          in mkSimpleDecorated $
@@ -1778,8 +1782,12 @@ instance Diagnostic TcRnMessage where
       -> case bindings of
           []     -> noHints
           (x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]
-    TcRnOrphanInstance{}
-      -> [SuggestFixOrphanInstance]
+    TcRnOrphanInstance clsOrFamInst
+      -> [SuggestFixOrphanInst { isFamilyInstance = isFam }]
+        where
+          isFam = case clsOrFamInst :: Either ClsInst FamInst of
+            Left  _clsInst -> Nothing
+            Right famInst  -> Just $ fi_flavor famInst
     TcRnFunDepConflict{}
       -> noHints
     TcRnDupInstanceDecls{}
diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs
index 3846dd874d..c377e32eaa 100644
--- a/compiler/GHC/Tc/Errors/Types.hs
+++ b/compiler/GHC/Tc/Errors/Types.hs
@@ -1079,17 +1079,17 @@ data TcRnMessage where
   -}
   TcRnMonomorphicBindings :: [Name] -> TcRnMessage
 
-  {-| TcRnOrphanInstance is a warning (controlled by -Wwarn-orphans)
-      that arises when a typeclass instance is an \"orphan\", i.e. if it appears
-      in a module in which neither the class nor the type being instanced are
-      declared in the same module.
+  {-| TcRnOrphanInstance is a warning (controlled by -Worphans) that arises when
+      a typeclass instance or family instance is an \"orphan\", i.e. if it
+      appears in a module in which neither the class/family nor the type being
+      instanced are declared in the same module.
 
       Examples(s): None
 
       Test cases: warnings/should_compile/T9178
                   typecheck/should_compile/T4912
   -}
-  TcRnOrphanInstance :: ClsInst -> TcRnMessage
+  TcRnOrphanInstance :: Either ClsInst FamInst -> TcRnMessage
 
   {-| TcRnFunDepConflict is an error that occurs when there are functional dependencies
       conflicts between instance declarations.
diff --git a/compiler/GHC/Tc/Instance/Family.hs b/compiler/GHC/Tc/Instance/Family.hs
index a555c04a69..5e2b523e4b 100644
--- a/compiler/GHC/Tc/Instance/Family.hs
+++ b/compiler/GHC/Tc/Instance/Family.hs
@@ -6,7 +6,6 @@ module GHC.Tc.Instance.Family (
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
         tcLookupDataFamInst, tcLookupDataFamInst_maybe,
         tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
-        newFamInst,
 
         -- * Injectivity
         reportInjectivityErrors, reportConflictingInjectivityErrs
@@ -18,7 +17,6 @@ import GHC.Driver.Session
 import GHC.Driver.Env
 
 import GHC.Core.FamInstEnv
-import GHC.Core.InstEnv( roughMatchTcs )
 import GHC.Core.Coercion
 import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
@@ -31,7 +29,6 @@ import GHC.Iface.Load
 import GHC.Tc.Errors.Types
 import GHC.Tc.Types.Evidence
 import GHC.Tc.Utils.Monad
-import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )
 import GHC.Tc.Utils.TcType
 
 import GHC.Unit.External
@@ -161,44 +158,6 @@ addressed yet.
 {-
 ************************************************************************
 *                                                                      *
-                 Making a FamInst
-*                                                                      *
-************************************************************************
--}
-
--- All type variables in a FamInst must be fresh. This function
--- creates the fresh variables and applies the necessary substitution
--- It is defined here to avoid a dependency from FamInstEnv on the monad
--- code.
-
-newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
--- Freshen the type variables of the FamInst branches
-newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })
-  = do {
-         -- Freshen the type variables
-         (subst, tvs') <- freshenTyVarBndrs tvs
-       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs
-       ; let lhs'     = substTys subst lhs
-             rhs'     = substTy  subst rhs
-
-       ; return (FamInst { fi_fam      = tyConName fam_tc
-                         , fi_flavor   = flavor
-                         , fi_tcs      = roughMatchTcs lhs
-                         , fi_tvs      = tvs'
-                         , fi_cvs      = cvs'
-                         , fi_tys      = lhs'
-                         , fi_rhs      = rhs'
-                         , fi_axiom    = axiom }) }
-  where
-    CoAxBranch { cab_tvs = tvs
-               , cab_cvs = cvs
-               , cab_lhs = lhs
-               , cab_rhs = rhs } = coAxiomSingleBranch axiom
-
-
-{-
-************************************************************************
-*                                                                      *
         Optimised overlap checking for family instances
 *                                                                      *
 ************************************************************************
diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs
index 9da7b05192..79374ac894 100644
--- a/compiler/GHC/Tc/TyCl/Class.hs
+++ b/compiler/GHC/Tc/TyCl/Class.hs
@@ -34,21 +34,24 @@ import GHC.Tc.Types.Evidence ( idHsWrapper )
 import GHC.Tc.Gen.Bind
 import GHC.Tc.Utils.Env
 import GHC.Tc.Utils.Unify
-import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars )
+import GHC.Tc.Utils.Instantiate( newFamInst, tcSuperSkolTyVars )
 import GHC.Tc.Gen.HsType
 import GHC.Tc.Utils.TcMType
-import GHC.Core.Type     ( piResultTys )
-import GHC.Core.Predicate
-import GHC.Core.Multiplicity
 import GHC.Tc.Types.Origin
 import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.Monad
 import GHC.Tc.TyCl.Build( TcMethInfo )
+
+import GHC.Core.Type     ( piResultTys )
+import GHC.Core.Predicate
+import GHC.Core.Multiplicity
 import GHC.Core.Class
 import GHC.Core.Coercion ( pprCoAxiom )
-import GHC.Driver.Session
-import GHC.Tc.Instance.Family
 import GHC.Core.FamInstEnv
+import GHC.Core.TyCon
+
+import GHC.Driver.Session
+
 import GHC.Types.Error
 import GHC.Types.Id
 import GHC.Types.Name
@@ -57,13 +60,14 @@ import GHC.Types.Name.Set
 import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.SourceFile (HscSource(..))
+import GHC.Types.SrcLoc
+import GHC.Types.Basic
+
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import GHC.Types.SrcLoc
-import GHC.Core.TyCon
+
 import GHC.Data.Maybe
-import GHC.Types.Basic
 import GHC.Data.Bag
 import GHC.Data.BooleanFormula
 
diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs
index b8249bc363..85671a0af5 100644
--- a/compiler/GHC/Tc/Utils/Instantiate.hs
+++ b/compiler/GHC/Tc/Utils/Instantiate.hs
@@ -27,7 +27,7 @@ module GHC.Tc.Utils.Instantiate (
 
      newOverloadedLit, mkOverLit,
 
-     newClsInst,
+     newClsInst, newFamInst,
      tcGetInsts, tcGetInstEnvs, getOverlapFlag,
      tcExtendLocalInstEnv,
      instCallConstraints, newMethodFromName,
@@ -50,12 +50,14 @@ import GHC.Hs
 import GHC.Hs.Syn.Type   ( hsLitType )
 
 import GHC.Core.InstEnv
+import GHC.Core.FamInstEnv
 import GHC.Core.Predicate
 import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor
 import GHC.Core.Type
 import GHC.Core.TyCo.Ppr ( debugPprType )
 import GHC.Core.Class( Class )
 import GHC.Core.DataCon
+import GHC.Core.Coercion.Axiom
 
 import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )
 import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType )
@@ -99,7 +101,7 @@ import Data.Function ( on )
 {-
 ************************************************************************
 *                                                                      *
-                Creating and emittind constraints
+                Creating and emitting constraints
 *                                                                      *
 ************************************************************************
 -}
@@ -807,7 +809,7 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity
 {-
 ************************************************************************
 *                                                                      *
-                Instances
+                Class instances
 *                                                                      *
 ************************************************************************
 -}
@@ -849,10 +851,12 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
              --     helpful to use the same names
 
        ; oflag <- getOverlapFlag overlap_mode
-       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
-       ; when (isOrphan (is_orphan inst)) $
-          addDiagnostic (TcRnOrphanInstance inst)
-       ; return inst }
+       ; let cls_inst = mkLocalClsInst dfun oflag tvs' clas tys'
+
+       ; when (isOrphan (is_orphan cls_inst)) $
+         addDiagnostic (TcRnOrphanInstance $ Left cls_inst)
+
+       ; return cls_inst }
 
 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
   -- Add new locally-defined instances
@@ -915,9 +919,9 @@ addLocalInst (home_ie, my_insts) ispec
 
          ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
 
-{-
-Note [Signature files and type class instances]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+{- Note [Signature files and type class instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Instances in signature files do not have an effect when compiling:
 when you compile a signature against an implementation, you will
 see the instances WHETHER OR NOT the instance is declared in
@@ -963,11 +967,42 @@ type class instances in the EPS, see #9422 (sigof02dm)
 
 ************************************************************************
 *                                                                      *
-        Errors and tracing
+                Family instances
 *                                                                      *
 ************************************************************************
 -}
 
+-- All type variables in a FamInst must be fresh. This function
+-- creates the fresh variables and applies the necessary substitution
+-- It is defined here to avoid a dependency from FamInstEnv on the monad
+-- code.
+
+newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
+-- Freshen the type variables of the FamInst branches
+newFamInst flavor axiom
+  | CoAxBranch { cab_tvs = tvs
+               , cab_cvs = cvs
+               , cab_lhs = lhs
+               , cab_rhs = rhs } <- coAxiomSingleBranch axiom
+  = do { -- Freshen the type variables
+         (subst, tvs') <- freshenTyVarBndrs tvs
+       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs
+       ; let lhs'     = substTys subst lhs
+             rhs'     = substTy  subst rhs
+
+       ; let fam_inst = mkLocalFamInst flavor axiom tvs' cvs' lhs' rhs'
+       ; when (isOrphan (fi_orphan fam_inst)) $
+         addDiagnostic (TcRnOrphanInstance $ Right fam_inst)
+
+       ; return fam_inst }
+
+
+{- *********************************************************************
+*                                                                      *
+        Errors and tracing
+*                                                                      *
+********************************************************************* -}
+
 traceDFuns :: [ClsInst] -> TcRn ()
 traceDFuns ispecs
   = traceTc "Adding instances:" (vcat (map pp ispecs))
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index dc6bbe746b..67b19c032a 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -97,8 +97,6 @@ module GHC.Tc.Utils.TcType (
   -- Misc type manipulators
 
   deNoteType,
-  orphNamesOfType, orphNamesOfCo,
-  orphNamesOfTypes, orphNamesOfCoCon,
   getDFunTyKey, evVarPred,
   ambigTkvsOfTy,
 
@@ -235,7 +233,6 @@ import {-# SOURCE #-} GHC.Tc.Types.Origin
 
 -- others:
 import GHC.Driver.Session
-import GHC.Core.FVs
 import GHC.Types.Name as Name
             -- We use this to make dictionaries for type literals.
             -- Perhaps there's a better way to do this?
diff --git a/compiler/GHC/Types/Hint.hs b/compiler/GHC/Types/Hint.hs
index 7e194ed194..9f897feb7f 100644
--- a/compiler/GHC/Types/Hint.hs
+++ b/compiler/GHC/Types/Hint.hs
@@ -31,6 +31,7 @@ import Data.Typeable
 import GHC.Unit.Module (ModuleName, Module)
 import GHC.Hs.Extension (GhcTc)
 import GHC.Core.Coercion
+import GHC.Core.FamInstEnv (FamFlavor)
 import GHC.Types.Fixity (LexicalFixity(..))
 import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName)
 import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec)
@@ -302,13 +303,18 @@ data GhcHint
     -}
   | SuggestTypeSignatureForm
 
-    {-| Suggests to move an orphan instance or to newtype-wrap it.
+    {-| Suggests to move an orphan instance (for a typeclass or a type or data
+        family), or to newtype-wrap it.
 
         Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance'
         Test cases(s): warnings/should_compile/T9178
                        typecheck/should_compile/T4912
+                       indexed-types/should_compile/T22717_fam_orph
     -}
-  | SuggestFixOrphanInstance
+  | SuggestFixOrphanInst
+    { isFamilyInstance :: Maybe FamFlavor }
+      -- ^ Whether this is a family instance (of the given 'FamFlavor'),
+      -- or a class instance ('Nothing').
 
     {-| Suggests to use a standalone deriving declaration when GHC
         can't derive a typeclass instance in a trivial way.
diff --git a/compiler/GHC/Types/Hint/Ppr.hs b/compiler/GHC/Types/Hint/Ppr.hs
index e6c42539e3..96fbd9f74f 100644
--- a/compiler/GHC/Types/Hint/Ppr.hs
+++ b/compiler/GHC/Types/Hint/Ppr.hs
@@ -12,6 +12,7 @@ import GHC.Prelude
 import GHC.Parser.Errors.Basic
 import GHC.Types.Hint
 
+import GHC.Core.FamInstEnv (FamFlavor(..))
 import GHC.Hs.Expr ()   -- instance Outputable
 import GHC.Types.Id
 import GHC.Types.Name (NameSpace, pprDefinedAt, occNameSpace, pprNameSpace, isValNameSpace, nameModule)
@@ -131,10 +132,15 @@ instance Outputable GhcHint where
          in case mb_mod of
               Nothing -> header <+> text "the hsig file."
               Just mod -> header <+> ppr (moduleName mod) <> text "'s hsig file."
-    SuggestFixOrphanInstance
-      -> vcat [ text "Move the instance declaration to the module of the class or of the type, or"
+    SuggestFixOrphanInst { isFamilyInstance = mbFamFlavor }
+      -> vcat [ text "Move the instance declaration to the module of the" <+> what <+> text "or of the type, or"
               , text "wrap the type with a newtype and declare the instance on the new type."
               ]
+      where
+        what = case mbFamFlavor of
+          Nothing                  -> text "class"
+          Just  SynFamilyInst      -> text "type family"
+          Just (DataFamilyInst {}) -> text "data family"
     SuggestAddStandaloneDerivation
       -> text "Use a standalone deriving declaration instead"
     SuggestFillInWildcardConstraint
diff --git a/testsuite/tests/indexed-types/should_compile/T22717.stderr b/testsuite/tests/indexed-types/should_compile/T22717.stderr
new file mode 100644
index 0000000000..241c302749
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717.stderr
@@ -0,0 +1,7 @@
+
+T22717c.hs:9:1: warning: [GHC-90177] [-Worphans (in -Wall)]
+    Orphan family instance:
+      type instance F T = Private -- Defined at T22717c.hs:9:15
+    Suggested fix:
+      Move the instance declaration to the module of the type family or of the type, or
+      wrap the type with a newtype and declare the instance on the new type.
diff --git a/testsuite/tests/indexed-types/should_compile/T22717_fam_orph.hs b/testsuite/tests/indexed-types/should_compile/T22717_fam_orph.hs
new file mode 100644
index 0000000000..a8c92822eb
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717_fam_orph.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Worphans #-}
+module T22717_fam_orph where
+
+import T22717_fam_orph_a
+
+data T
+
+type instance F Int = T -- Orphan instance!
diff --git a/testsuite/tests/indexed-types/should_compile/T22717_fam_orph.stderr b/testsuite/tests/indexed-types/should_compile/T22717_fam_orph.stderr
new file mode 100644
index 0000000000..177dd39ce3
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717_fam_orph.stderr
@@ -0,0 +1,7 @@
+
+T22717_fam_orph.hs:9:1: warning: [GHC-90177] [-Worphans (in -Wall)]
+    Orphan family instance:
+      type instance F Int = T -- Defined at T22717_fam_orph.hs:9:15
+    Suggested fix:
+      Move the instance declaration to the module of the type family or of the type, or
+      wrap the type with a newtype and declare the instance on the new type.
diff --git a/testsuite/tests/indexed-types/should_compile/T22717_fam_orph_a.hs b/testsuite/tests/indexed-types/should_compile/T22717_fam_orph_a.hs
new file mode 100644
index 0000000000..444930d407
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717_fam_orph_a.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717_fam_orph_a where
+
+type family F a
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index 5b4dc3bafd..ab00841493 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -307,3 +307,4 @@ test('T11715b', normal, ghci_script, ['T11715b.script'])
 test('T4254', normal, compile, [''])
 test('T22547', normal, compile, [''])
 test('T22717', normal, makefile_test, ['T22717'])
+test('T22717_fam_orph', normal, multimod_compile, ['T22717_fam_orph', '-v0'])
diff --git a/testsuite/tests/indexed-types/should_fail/T19773.hs b/testsuite/tests/indexed-types/should_fail/T19773.hs
new file mode 100644
index 0000000000..c598f1f401
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T19773.hs
@@ -0,0 +1,5 @@
+module T19973 where
+
+import T19773a
+import T19773b
+import T19773c
diff --git a/testsuite/tests/indexed-types/should_fail/T19773.stderr b/testsuite/tests/indexed-types/should_fail/T19773.stderr
new file mode 100644
index 0000000000..3d69a52d71
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T19773.stderr
@@ -0,0 +1,23 @@
+[1 of 4] Compiling T19773a          ( T19773a.hs, T19773a.o )
+[2 of 4] Compiling T19773b          ( T19773b.hs, T19773b.o )
+
+T19773b.hs:6:1: warning: [GHC-90177] [-Worphans (in -Wall)]
+    Orphan family instance:
+      data instance DF [a] -- Defined at T19773b.hs:6:15
+    Suggested fix:
+      Move the instance declaration to the module of the data family or of the type, or
+      wrap the type with a newtype and declare the instance on the new type.
+[3 of 4] Compiling T19773c          ( T19773c.hs, T19773c.o )
+
+T19773c.hs:6:1: warning: [GHC-90177] [-Worphans (in -Wall)]
+    Orphan family instance:
+      data instance DF [a] -- Defined at T19773c.hs:6:15
+    Suggested fix:
+      Move the instance declaration to the module of the data family or of the type, or
+      wrap the type with a newtype and declare the instance on the new type.
+[4 of 4] Compiling T19973           ( T19773.hs, T19773.o )
+
+T19773.hs:1:1: error: [GHC-34447]
+    Conflicting family instance declarations:
+      DF [a] -- Defined in module T19773b
+      DF [a] -- Defined in module T19773c
diff --git a/testsuite/tests/indexed-types/should_fail/T19773a.hs b/testsuite/tests/indexed-types/should_fail/T19773a.hs
new file mode 100644
index 0000000000..57503b94c6
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T19773a.hs
@@ -0,0 +1,4 @@
+{-# LANGUAGE TypeFamilies #-}
+module T19773a where
+
+data family DF a
diff --git a/testsuite/tests/indexed-types/should_fail/T19773b.hs b/testsuite/tests/indexed-types/should_fail/T19773b.hs
new file mode 100644
index 0000000000..fe967d8cb7
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T19773b.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module T19773b where
+import T19773a
+
+-- Should warn for orphan instance
+data instance DF [a] = DF_B a
diff --git a/testsuite/tests/indexed-types/should_fail/T19773c.hs b/testsuite/tests/indexed-types/should_fail/T19773c.hs
new file mode 100644
index 0000000000..b0ab867aa6
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T19773c.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TypeFamilies #-}
+module T19773c where
+import T19773a
+
+-- Should warn for orphan instance
+data instance DF [a] = DF_C a
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index e990d572c0..325fbc0614 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -171,3 +171,4 @@ test('T20521', normal, compile_fail, [''])
 test('T21896', normal, compile_fail, [''])
 test('HsBootFam', [extra_files(['HsBootFam_aux.hs','HsBootFam_aux.hs-boot'])], multimod_compile_fail, ['HsBootFam', ''])
 test('BadFamInstDecl', [extra_files(['BadFamInstDecl_aux.hs'])], multimod_compile_fail, ['BadFamInstDecl', ''])
+test('T19773', [], multimod_compile_fail, ['T19773', '-Wall'])
diff --git a/testsuite/tests/typecheck/should_compile/T4912.stderr b/testsuite/tests/typecheck/should_compile/T4912.stderr
index 243d3ff2e6..54edef9496 100644
--- a/testsuite/tests/typecheck/should_compile/T4912.stderr
+++ b/testsuite/tests/typecheck/should_compile/T4912.stderr
@@ -1,12 +1,12 @@
 
 T4912.hs:10:1: warning: [GHC-90177] [-Worphans (in -Wall)]
-    Orphan instance: instance Foo TheirData
+    Orphan class instance: instance Foo TheirData
     Suggested fix:
       Move the instance declaration to the module of the class or of the type, or
       wrap the type with a newtype and declare the instance on the new type.
 
 T4912.hs:13:1: warning: [GHC-90177] [-Worphans (in -Wall)]
-    Orphan instance: instance Bar OurData
+    Orphan class instance: instance Bar OurData
     Suggested fix:
       Move the instance declaration to the module of the class or of the type, or
       wrap the type with a newtype and declare the instance on the new type.
diff --git a/testsuite/tests/warnings/should_compile/T9178.stderr b/testsuite/tests/warnings/should_compile/T9178.stderr
index ca2af9a850..2d51565ee8 100644
--- a/testsuite/tests/warnings/should_compile/T9178.stderr
+++ b/testsuite/tests/warnings/should_compile/T9178.stderr
@@ -2,7 +2,7 @@
 [2 of 2] Compiling T9178            ( T9178.hs, T9178.o )
 
 T9178.hs:8:1: warning: [GHC-90177] [-Worphans (in -Wall)]
-    Orphan instance: instance Show T9178_Type
+    Orphan class instance: instance Show T9178_Type
     Suggested fix:
       Move the instance declaration to the module of the class or of the type, or
       wrap the type with a newtype and declare the instance on the new type.