[Git][ghc/ghc][wip/T22717] Detect family instance orphans correctly
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Jan 20 23:08:03 UTC 2023
Simon Peyton Jones pushed to branch wip/T22717 at Glasgow Haskell Compiler / GHC
Commits:
bfb381de by Simon Peyton Jones at 2023-01-20T23:08:06+00:00
Detect family instance orphans correctly
This MR fixes two bugs, both in #22717.
1. We were treating a type-family instance as a non-orphan if there
was a type constructor on it /right-hand side/ that was local.Boo!
Utterly wrong.
The fix is trivial: look only at the LHS
2. We were not reporting orphan family instances at all.
The fix here is easy, but touches more code. I refactored it 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
- I added a new error constructor TcRnOrphanFamInst, and renamed
the existing TcRnOrphanInstance to TcRnOrphanClsInst
- Ditto SuggestFixOrphanFamInst
- - - - -
30 changed files:
- compiler/GHC.hs
- compiler/GHC/Core.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/FamInstEnv.hs
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Iface/Make.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Runtime/Eval.hs
- compiler/GHC/Stg/InferTags/TagSig.hs
- compiler/GHC/Stg/Pipeline.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Instance/Family.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/Utils/Instantiate.hs
- compiler/GHC/Tc/Utils/TcType.hs
- compiler/GHC/Types/Error/Codes.hs
- compiler/GHC/Types/Hint.hs
- compiler/GHC/Types/Hint/Ppr.hs
- testsuite/tests/indexed-types/should_compile/Makefile
- + testsuite/tests/indexed-types/should_compile/T22717.hs
- + testsuite/tests/indexed-types/should_compile/T22717_fam_orph.hs
- + testsuite/tests/indexed-types/should_compile/T22717_fam_orph_a.hs
- + testsuite/tests/indexed-types/should_compile/T22717b.hs
- + testsuite/tests/indexed-types/should_compile/T22717c.hs
- + testsuite/tests/indexed-types/should_compile/T22717d.hs
- testsuite/tests/indexed-types/should_compile/all.T
Changes:
=====================================
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
=====================================
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
=====================================
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 oprhNamesOfFamInst) 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
=====================================
compiler/GHC/Core/FamInstEnv.hs
=====================================
@@ -10,8 +10,8 @@
module GHC.Core.FamInstEnv (
FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,
famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,
- pprFamInst, pprFamInsts,
- mkImportedFamInst,
+ pprFamInst, pprFamInsts, orphNamesOfFamInst,
+ 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
@@ -47,6 +48,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 +64,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
@@ -123,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
@@ -207,6 +213,10 @@ dataFamInstRepTyCon fi
DataFamilyInst tycon -> tycon
SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi)
+orphNamesOfFamInst :: FamInst -> NameSet
+orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax
+
+
{-
************************************************************************
* *
@@ -247,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]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -270,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,
@@ -280,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
=====================================
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
=====================================
compiler/GHC/Iface/Make.hs
=====================================
@@ -98,7 +98,7 @@ import Data.Function
import Data.List ( findIndex, mapAccumL, sortBy )
import Data.Ord
import Data.IORef
-import GHC.Stg.Pipeline (StgCgInfos)
+import GHC.Stg.InferTags.TagSig (StgCgInfos)
{-
@@ -722,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 (orphNamesOfCoCon 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
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1238,17 +1238,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) }
{-
************************************************************************
=====================================
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
=====================================
compiler/GHC/Stg/InferTags/TagSig.hs
=====================================
@@ -13,11 +13,21 @@ where
import GHC.Prelude
import GHC.Types.Var
+import GHC.Types.Name.Env( NameEnv )
import GHC.Utils.Outputable
import GHC.Utils.Binary
import GHC.Utils.Panic.Plain
import Data.Coerce
+-- | Information to be exposed in interface files which is produced
+-- by the stg2stg passes.
+type StgCgInfos = NameEnv TagSig
+
+newtype TagSig -- The signature for each binding, this is a newtype as we might
+ -- want to track more information in the future.
+ = TagSig TagInfo
+ deriving (Eq)
+
data TagInfo
= TagDunno -- We don't know anything about the tag.
| TagTuple [TagInfo] -- Represents a function/thunk which when evaluated
@@ -46,11 +56,6 @@ instance Binary TagInfo where
4 -> return TagTagged
_ -> panic ("get TagInfo " ++ show tag)
-newtype TagSig -- The signature for each binding, this is a newtype as we might
- -- want to track more information in the future.
- = TagSig TagInfo
- deriving (Eq)
-
instance Outputable TagSig where
ppr (TagSig ti) = char '<' <> ppr ti <> char '>'
instance OutputableBndr (Id,TagSig) where
=====================================
compiler/GHC/Stg/Pipeline.hs
=====================================
@@ -42,7 +42,7 @@ import Control.Monad.Trans.Reader
import GHC.Settings (Platform)
import GHC.Stg.InferTags (inferTags)
import GHC.Types.Name.Env (NameEnv)
-import GHC.Stg.InferTags.TagSig (TagSig)
+import GHC.Stg.InferTags.TagSig ( StgCgInfos )
data StgPipelineOpts = StgPipelineOpts
{ stgPipeline_phases :: ![StgToDo]
@@ -56,10 +56,6 @@ data StgPipelineOpts = StgPipelineOpts
newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }
deriving (Functor, Applicative, Monad, MonadIO)
--- | Information to be exposed in interface files which is produced
--- by the stg2stg passes.
-type StgCgInfos = NameEnv TagSig
-
instance MonadUnique StgM where
getUniqueSupplyM = StgM $ do { mask <- ask
; liftIO $! mkSplitUniqSupply mask}
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -44,52 +44,56 @@ 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.Instance.Family
+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
=====================================
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)
=====================================
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, 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
@@ -53,6 +54,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)
@@ -416,11 +418,15 @@ instance Diagnostic TcRnMessage where
sep [ text "The Monomorphism Restriction applies to the binding"
<> plural bindings
, text "for" <+> pp_bndrs ]
- TcRnOrphanInstance inst
+ TcRnOrphanClsInst cls_inst
-> mkSimpleDecorated $
- hsep [ text "Orphan instance:"
- , pprInstanceHdr inst
- ]
+ hang (text "Orphan class instance:")
+ 2 (pprInstanceHdr cls_inst)
+ TcRnOrphanFamInst 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 $
@@ -1365,7 +1371,9 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnMonomorphicBindings{}
-> WarningWithFlag Opt_WarnMonomorphism
- TcRnOrphanInstance{}
+ TcRnOrphanClsInst{}
+ -> WarningWithFlag Opt_WarnOrphans
+ TcRnOrphanFamInst{}
-> WarningWithFlag Opt_WarnOrphans
TcRnFunDepConflict{}
-> ErrorWithoutFlag
@@ -1781,8 +1789,10 @@ instance Diagnostic TcRnMessage where
-> case bindings of
[] -> noHints
(x:xs) -> [SuggestAddTypeSignatures $ NamedBindings (x NE.:| xs)]
- TcRnOrphanInstance{}
- -> [SuggestFixOrphanInstance]
+ TcRnOrphanClsInst{}
+ -> [SuggestFixOrphanClsInst]
+ TcRnOrphanFamInst{}
+ -> [SuggestFixOrphanFamInst]
TcRnFunDepConflict{}
-> noHints
TcRnDupInstanceDecls{}
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -1079,9 +1079,9 @@ 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
+ {-| TcRnOrphanClsInst and TcRnOrphanFamInst ared warnings (controlled by -Wwarn-orphans)
+ that arise when a typeclass instance or family 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.
Examples(s): None
@@ -1089,7 +1089,8 @@ data TcRnMessage where
Test cases: warnings/should_compile/T9178
typecheck/should_compile/T4912
-}
- TcRnOrphanInstance :: ClsInst -> TcRnMessage
+ TcRnOrphanClsInst :: ClsInst -> TcRnMessage
+ TcRnOrphanFamInst :: FamInst -> TcRnMessage
{-| TcRnFunDepConflict is an error that occurs when there are functional dependencies
conflicts between instance declarations.
=====================================
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
@@ -158,44 +155,6 @@ addressed yet.
See Note [Loading your own hi-boot file] in GHC.Iface.Load.
-}
-{-
-************************************************************************
-* *
- 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
-
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -112,7 +112,7 @@ import GHC.Hs.Dump
import GHC.Core.PatSyn ( pprPatSynType )
import GHC.Core.Predicate ( classMethodTy )
-import GHC.Core.FVs ( orphNamesOfFamInst )
+import GHC.Core.FamInstEnv( orphNamesOfFamInst )
import GHC.Core.InstEnv
import GHC.Core.TyCon
import GHC.Core.ConLike
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -37,18 +37,22 @@ import GHC.Tc.Utils.Unify
import GHC.Tc.Utils.Instantiate( 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.Utils.Instantiate( newFamInst )
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 +61,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
=====================================
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 (TcRnOrphanClsInst 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 (TcRnOrphanFamInst fam_inst)
+
+ ; return fam_inst }
+
+
+{- *********************************************************************
+* *
+ Errors and tracing
+* *
+********************************************************************* -}
+
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns ispecs
= traceTc "Adding instances:" (vcat (map pp ispecs))
=====================================
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,
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -381,7 +381,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnBadAssociatedType" = 38351
GhcDiagnosticCode "TcRnForAllRankErr" = 91510
GhcDiagnosticCode "TcRnMonomorphicBindings" = 55524
- GhcDiagnosticCode "TcRnOrphanInstance" = 90177
+ GhcDiagnosticCode "TcRnOrphanClsInst" = 90177
+ GhcDiagnosticCode "TcRnOrphanFamInst" = 61125
GhcDiagnosticCode "TcRnFunDepConflict" = 46208
GhcDiagnosticCode "TcRnDupInstanceDecls" = 59692
GhcDiagnosticCode "TcRnConflictingFamInstDecls" = 34447
=====================================
compiler/GHC/Types/Hint.hs
=====================================
@@ -302,13 +302,20 @@ data GhcHint
-}
| SuggestTypeSignatureForm
- {-| Suggests to move an orphan instance or to newtype-wrap it.
+ {-| Suggests to move an orphan typeclass instance or to newtype-wrap it.
- Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanInstance'
+ Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanClsInst'
Test cases(s): warnings/should_compile/T9178
typecheck/should_compile/T4912
-}
- | SuggestFixOrphanInstance
+ | SuggestFixOrphanClsInst
+
+ {-| Suggests to move an orphan typeclass instance or to newtype-wrap it.
+
+ Triggered by: 'GHC.Tc.Errors.Types.TcRnOrphanClsInst'
+ Test cases(s): indexed-types/should_compile/T22717_fam_orph
+ -}
+ | SuggestFixOrphanFamInst
{-| Suggests to use a standalone deriving declaration when GHC
can't derive a typeclass instance in a trivial way.
=====================================
compiler/GHC/Types/Hint/Ppr.hs
=====================================
@@ -131,10 +131,14 @@ 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
+ SuggestFixOrphanClsInst
-> vcat [ text "Move the instance declaration to the module of the class or of the type, or"
, text "wrap the type with a newtype and declare the instance on the new type."
]
+ SuggestFixOrphanFamInst
+ -> vcat [ text "Move the instance declaration to the module of the type family or of the type, or"
+ , text "wrap the type with a newtype and declare the instance on the new type."
+ ]
SuggestAddStandaloneDerivation
-> text "Use a standalone deriving declaration instead"
SuggestFillInWildcardConstraint
=====================================
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
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717c.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717b.hs
+ '$(TEST_HC)' $(TEST_HC_OPTS) -c T22717.hs
=====================================
testsuite/tests/indexed-types/should_compile/T22717.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717 where
+
+import T22717b
+
+f = p (3::Int)
+
=====================================
testsuite/tests/indexed-types/should_compile/T22717_fam_orph.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717_fam_orph where
+
+import T22717_fam_orph_a
+
+data T = MkT
+
+type instance F Int = MkT -- Orphan instance!
=====================================
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
=====================================
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
=====================================
testsuite/tests/indexed-types/should_compile/T22717c.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717c() where
+
+import T22717d
+
+data Private = Private
+
+type instance F T = Private
+type instance F Private = Int
=====================================
testsuite/tests/indexed-types/should_compile/T22717d.hs
=====================================
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+module T22717d where
+
+type family F a
+data T = MkT
=====================================
testsuite/tests/indexed-types/should_compile/all.T
=====================================
@@ -306,3 +306,5 @@ test('T19336', normal, compile, ['-O'])
test('T11715b', normal, ghci_script, ['T11715b.script'])
test('T4254', normal, compile, [''])
test('T22547', normal, compile, [''])
+test('T22717_fam_orph', normal, multimod_compile, ['T22717_fam_orph', '-v0'])
+test('T22717', normal, makefile_test, ['T22717'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfb381defa7d8efca56eb184a7538b6239e90151
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bfb381defa7d8efca56eb184a7538b6239e90151
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230120/14904c75/attachment-0001.html>
More information about the ghc-commits
mailing list