summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simon.peytonjones@gmail.com>2023-01-26 16:16:32 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-01-27 23:54:55 -0500
commit638277ba7bd2683f539afb0bf469fe75376994e2 (patch)
treee5e0a9f4d8a7d0ea6c3a610e5ab105293ae91a5e
parent545bf8cf1844e2a1c18d2019d1f299ab10099873 (diff)
downloadhaskell-638277ba7bd2683f539afb0bf469fe75376994e2.tar.gz
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
-rw-r--r--compiler/GHC.hs3
-rw-r--r--compiler/GHC/Core/FVs.hs23
-rw-r--r--compiler/GHC/Core/FamInstEnv.hs9
-rw-r--r--compiler/GHC/Iface/Make.hs3
-rw-r--r--compiler/GHC/Runtime/Eval.hs3
-rw-r--r--compiler/GHC/Tc/Errors/Ppr.hs3
-rw-r--r--compiler/GHC/Tc/Module.hs3
-rw-r--r--testsuite/tests/indexed-types/should_compile/Makefile8
-rw-r--r--testsuite/tests/indexed-types/should_compile/T22717.hs8
-rw-r--r--testsuite/tests/indexed-types/should_compile/T22717b.hs8
-rw-r--r--testsuite/tests/indexed-types/should_compile/T22717c.hs12
-rw-r--r--testsuite/tests/indexed-types/should_compile/T22717d.hs5
-rw-r--r--testsuite/tests/indexed-types/should_compile/all.T1
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'])