Detect family instance orphans correctly

We were treating a type-family instance as a non-orphan if there
was a type constructor on its /right-hand side/ that was local. Boo!
Utterly wrong. With this patch, we correctly check the /left-hand side/
instead!

Fixes #22717

13 files changed, 67 insertions, 22 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 308ea08780..dfa5bf5ff2 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -366,8 +366,7 @@ import GHC.Core.TyCon
 import GHC.Core.TyCo.Ppr   ( pprForAll )
 import GHC.Core.Class
 import GHC.Core.DataCon
-import GHC.Core.FVs        ( orphNamesOfFamInst )
-import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
+import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst )
 import GHC.Core.InstEnv
 import GHC.Core
 
diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs
index 65b654356e..bddd6d89de 100644
--- a/compiler/GHC/Core/FVs.hs
+++ b/compiler/GHC/Core/FVs.hs
@@ -39,9 +39,9 @@ module GHC.Core.FVs (
         exprFVs,
 
         -- * Orphan names
-        orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,
-        orphNamesOfTypes, orphNamesOfCoCon,
-        exprsOrphNames, orphNamesOfFamInst,
+        orphNamesOfType, orphNamesOfTypes,
+        orphNamesOfCo,  orphNamesOfCoCon, orphNamesOfAxiomLHS,
+        exprsOrphNames,
 
         -- * Core syntax tree annotation with free variables
         FVAnn,                  -- annotation, abstract
@@ -70,7 +70,6 @@ import GHC.Core.TyCo.Rep
 import GHC.Core.TyCo.FVs
 import GHC.Core.TyCon
 import GHC.Core.Coercion.Axiom
-import GHC.Core.FamInstEnv
 import GHC.Builtin.Types( unrestrictedFunTyConName )
 import GHC.Builtin.Types.Prim( fUNTyCon )
 import GHC.Data.Maybe( orElse )
@@ -420,11 +419,6 @@ orphNamesOfCoCon :: CoAxiom br -> NameSet
 orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
   = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches
 
-orphNamesOfAxiom :: CoAxiom br -> NameSet
-orphNamesOfAxiom axiom
-  = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
-    `extendNameSet` getName (coAxiomTyCon axiom)
-
 orphNamesOfCoAxBranches :: Branches br -> NameSet
 orphNamesOfCoAxBranches
   = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches
@@ -433,16 +427,19 @@ orphNamesOfCoAxBranch :: CoAxBranch -> NameSet
 orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
   = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs
 
--- | orphNamesOfAxiom collects the names of the concrete types and
+-- | `orphNamesOfAxiomLHS` collects the names of the concrete types and
 -- type constructors that make up the LHS of a type family instance,
 -- including the family name itself.
 --
 -- For instance, given `type family Foo a b`:
 -- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H]
 --
--- Used in the implementation of ":info" in GHCi.
-orphNamesOfFamInst :: FamInst -> NameSet
-orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)
+-- Used (via orphNamesOfFamInst) in the implementation of ":info" in GHCi.
+-- and when determining orphan-hood for a FamInst or module
+orphNamesOfAxiomLHS :: CoAxiom br -> NameSet
+orphNamesOfAxiomLHS axiom
+  = (orphNamesOfTypes $ concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom)
+    `extendNameSet` getName (coAxiomTyCon axiom)
 
 -- Detect FUN 'Many as an application of (->), so that :i (->) works as expected
 -- (see #8535) Issue #16475 describes a more robust solution
diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs
index 121c8ffe10..a51377c2d0 100644
--- a/compiler/GHC/Core/FamInstEnv.hs
+++ b/compiler/GHC/Core/FamInstEnv.hs
@@ -10,7 +10,7 @@
 module GHC.Core.FamInstEnv (
         FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
         famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,
-        pprFamInst, pprFamInsts,
+        pprFamInst, pprFamInsts, orphNamesOfFamInst,
         mkImportedFamInst,
 
         FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,
@@ -47,6 +47,7 @@ import GHC.Core.Coercion
 import GHC.Core.Coercion.Axiom
 import GHC.Core.Reduction
 import GHC.Core.RoughMap
+import GHC.Core.FVs( orphNamesOfAxiomLHS )
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Types.Name
@@ -62,6 +63,8 @@ import GHC.Utils.Misc
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
+
+import GHC.Types.Name.Set
 import GHC.Data.Bag
 import GHC.Data.List.Infinite (Infinite (..))
 import qualified GHC.Data.List.Infinite as Inf
@@ -207,6 +210,10 @@ dataFamInstRepTyCon fi
        DataFamilyInst tycon -> tycon
        SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi)
 
+orphNamesOfFamInst :: FamInst -> NameSet
+orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index ac55220cbf..b6865e8e60 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -42,6 +42,7 @@ 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
@@ -740,7 +741,7 @@ famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,
           nameModule (coAxiomName axiom)
     is_local name = nameIsLocalOrFrom mod name
 
-    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)
+    lhs_names = filterNameSet is_local (orphNamesOfAxiomLHS axiom)
 
     orph | is_local fam_decl
          = NotOrphan (nameOccName fam_decl)
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 7ee9b07050..b6cf935b7e 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -68,8 +68,7 @@ import GHC.Hs
 
 import GHC.Core.Predicate
 import GHC.Core.InstEnv
-import GHC.Core.FamInstEnv ( FamInst )
-import GHC.Core.FVs        ( orphNamesOfFamInst )
+import GHC.Core.FamInstEnv ( FamInst, orphNamesOfFamInst )
 import GHC.Core.TyCon
 import GHC.Core.Type       hiding( typeKind )
 import GHC.Core.TyCo.Ppr
diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index e173567844..ffe1d1c196 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 ( famInstAxiom )
 import GHC.Core.InstEnv
 import GHC.Core.TyCo.Rep (Type(..))
 import GHC.Core.TyCo.Ppr (pprWithExplicitKindsWhen,
@@ -53,6 +53,7 @@ import {-# SOURCE #-} GHC.Tc.Types( getLclEnvLoc, lclEnvInGeneratedCode )
 import GHC.Tc.Types.Origin
 import GHC.Tc.Types.Rank (Rank(..))
 import GHC.Tc.Utils.TcType
+
 import GHC.Types.Error
 import GHC.Types.FieldLabel (flIsOverloaded)
 import GHC.Types.Hint (UntickedPromotedThing(..), pprUntickedConstructor, isBareSymbol)
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index 24a5d07090..edfa5a9258 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -112,7 +112,6 @@ import GHC.Hs.Dump
 
 import GHC.Core.PatSyn    ( pprPatSynType )
 import GHC.Core.Predicate ( classMethodTy )
-import GHC.Core.FVs         ( orphNamesOfFamInst )
 import GHC.Core.InstEnv
 import GHC.Core.TyCon
 import GHC.Core.ConLike
@@ -124,7 +123,7 @@ import GHC.Core.Reduction ( Reduction(..) )
 import GHC.Core.RoughMap( RoughMatchTc(..) )
 import GHC.Core.TyCo.Ppr( debugPprType )
 import GHC.Core.FamInstEnv
-   ( FamInst, pprFamInst, famInstsRepTyCons
+   ( FamInst, pprFamInst, famInstsRepTyCons, orphNamesOfFamInst
    , famInstEnvElts, extendFamInstEnvList, normaliseType )
 
 import GHC.Parser.Header       ( mkPrelImports )
diff --git a/testsuite/tests/indexed-types/should_compile/Makefile b/testsuite/tests/indexed-types/should_compile/Makefile
index e5970c0c56..6f3eb57268 100644
--- a/testsuite/tests/indexed-types/should_compile/Makefile
+++ b/testsuite/tests/indexed-types/should_compile/Makefile
@@ -41,3 +41,11 @@ T8500:
 	$(RM) T8500a.o T8500a.hi T8500.o T8500.hi
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T8500a.hs
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T8500.hs
+
+# T22717 must be done in one-shot mode, one file at a time
+T22717:
+	$(RM) T22717*.o T22717*.hi
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T22717d.hs -Wall
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T22717c.hs -Wall
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T22717b.hs -Wall
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c T22717.hs  -Wall
diff --git a/testsuite/tests/indexed-types/should_compile/T22717.hs b/testsuite/tests/indexed-types/should_compile/T22717.hs
new file mode 100644
index 0000000000..6eb4a9ffcc
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717 where
+
+import T22717b
+
+f :: Int
+f = p (3::Int)
+
diff --git a/testsuite/tests/indexed-types/should_compile/T22717b.hs b/testsuite/tests/indexed-types/should_compile/T22717b.hs
new file mode 100644
index 0000000000..5d5cd8e816
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717b.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717b where
+
+import T22717c ()
+import T22717d
+
+p :: F (F T) -> Int
+p _ = 3
diff --git a/testsuite/tests/indexed-types/should_compile/T22717c.hs b/testsuite/tests/indexed-types/should_compile/T22717c.hs
new file mode 100644
index 0000000000..8b36c902cf
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717c.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE EmptyDataDecls, TypeFamilies #-}
+module T22717c() where
+
+import T22717d
+
+data Private
+
+-- This is an orphan instance
+type instance F T = Private
+
+-- But this is not
+type instance F Private = Int
diff --git a/testsuite/tests/indexed-types/should_compile/T22717d.hs b/testsuite/tests/indexed-types/should_compile/T22717d.hs
new file mode 100644
index 0000000000..299636094a
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T22717d.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717d where
+
+type family F a
+data T
diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T
index b65d9dc382..5b4dc3bafd 100644
--- a/testsuite/tests/indexed-types/should_compile/all.T
+++ b/testsuite/tests/indexed-types/should_compile/all.T
@@ -306,3 +306,4 @@ test('T19336', normal, compile, ['-O'])
 test('T11715b', normal, ghci_script, ['T11715b.script'])
 test('T4254', normal, compile, [''])
 test('T22547', normal, compile, [''])
+test('T22717', normal, makefile_test, ['T22717'])