{-# LANGUAGE GADTs, ViewPatterns #-}
module GHC.Tc.Instance.Family (
FamInstEnvs, tcGetFamInstEnvs,
checkFamInstConsistency, tcExtendLocalFamInstEnv,
tcLookupDataFamInst, tcLookupDataFamInst_maybe,
tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,
newFamInst,
reportInjectivityErrors, reportConflictingInjectivityErrs
) where
import GHC.Prelude
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
import GHC.Core.DataCon ( dataConName )
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs
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
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.Deps
import GHC.Unit.Home.ModInfo
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.FV
import GHC.Data.Bag( Bag, unionBags, unitBag )
import GHC.Data.Maybe
import Control.Monad
import Data.List.NonEmpty ( NonEmpty(..) )
import qualified Data.List.NonEmpty as NE
import Data.Function ( on )
import qualified GHC.LanguageExtensions as LangExt
import GHC.Unit.Env (unitEnv_hpts)
newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
flavor axiom :: CoAxiom Unbranched
axiom@(CoAxiom { co_ax_tc :: forall (br :: BranchFlag). CoAxiom br -> TyCon
co_ax_tc = TyCon
fam_tc })
= do {
(TCvSubst
subst, [TyVar]
tvs') <- [TyVar] -> TcM (TCvSubst, [TyVar])
freshenTyVarBndrs [TyVar]
tvs
; (TCvSubst
subst, [TyVar]
cvs') <- TCvSubst -> [TyVar] -> TcM (TCvSubst, [TyVar])
freshenCoVarBndrsX TCvSubst
subst [TyVar]
cvs
; let lhs' :: [Type]
lhs' = (() :: Constraint) => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
lhs
rhs' :: Type
rhs' = (() :: Constraint) => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
rhs
; FamInst -> TcM FamInst
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamInst { fi_fam :: Name
fi_fam = TyCon -> Name
tyConName TyCon
fam_tc
, fi_flavor :: FamFlavor
fi_flavor = FamFlavor
flavor
, fi_tcs :: [RoughMatchTc]
fi_tcs = [Type] -> [RoughMatchTc]
roughMatchTcs [Type]
lhs
, fi_tvs :: [TyVar]
fi_tvs = [TyVar]
tvs'
, fi_cvs :: [TyVar]
fi_cvs = [TyVar]
cvs'
, fi_tys :: [Type]
fi_tys = [Type]
lhs'
, fi_rhs :: Type
fi_rhs = Type
rhs'
, fi_axiom :: CoAxiom Unbranched
fi_axiom = CoAxiom Unbranched
axiom }) }
where
CoAxBranch { cab_tvs :: CoAxBranch -> [TyVar]
cab_tvs = [TyVar]
tvs
, cab_cvs :: CoAxBranch -> [TyVar]
cab_cvs = [TyVar]
cvs
, cab_lhs :: CoAxBranch -> [Type]
cab_lhs = [Type]
lhs
, cab_rhs :: CoAxBranch -> Type
cab_rhs = Type
rhs } = CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
axiom
checkFamInstConsistency :: [Module] -> TcM ()
checkFamInstConsistency :: [Module] -> TcM ()
checkFamInstConsistency [Module]
directlyImpMods
= do { (ExternalPackageState
eps, HomeUnitGraph
hug) <- TcRnIf TcGblEnv TcLclEnv (ExternalPackageState, HomeUnitGraph)
forall gbl lcl.
TcRnIf gbl lcl (ExternalPackageState, HomeUnitGraph)
getEpsAndHug
; String -> SDoc -> TcM ()
traceTc String
"checkFamInstConsistency" ([Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Module]
directlyImpMods)
; let {
modIface :: Module -> ModIface
modIface Module
mod =
case HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hug (ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
eps) Module
mod of
Maybe ModIface
Nothing -> String -> SDoc -> ModIface
forall a. String -> SDoc -> a
panicDoc String
"FamInst.checkFamInstConsistency"
(Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
$$ HomeUnitGraph -> SDoc
forall a. Outputable a => a -> SDoc
ppr HomeUnitGraph
hug)
Just ModIface
iface -> ModIface
iface
; modConsistent :: Module -> [Module]
; modConsistent :: Module -> [Module]
modConsistent Module
mod =
if ModIfaceBackend -> WhetherHasFamInst
mi_finsts (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts (Module -> ModIface
modIface Module
mod)) then Module
modModule -> [Module] -> [Module]
forall a. a -> [a] -> [a]
:[Module]
deps else [Module]
deps
where
deps :: [Module]
deps = Dependencies -> [Module]
dep_finsts (Dependencies -> [Module])
-> (Module -> Dependencies) -> Module -> [Module]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> Dependencies
forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps (ModIface -> Dependencies)
-> (Module -> ModIface) -> Module -> Dependencies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModIface
modIface (Module -> [Module]) -> Module -> [Module]
forall a b. (a -> b) -> a -> b
$ Module
mod
; hmiModule :: HomeModInfo -> Module
hmiModule = ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (ModIface -> Module)
-> (HomeModInfo -> ModIface) -> HomeModInfo -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModIface
hm_iface
; hmiFamInstEnv :: HomeModInfo -> FamInstEnv
hmiFamInstEnv = FamInstEnv -> [FamInst] -> FamInstEnv
extendFamInstEnvList FamInstEnv
emptyFamInstEnv
([FamInst] -> FamInstEnv)
-> (HomeModInfo -> [FamInst]) -> HomeModInfo -> FamInstEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModDetails -> [FamInst]
md_fam_insts (ModDetails -> [FamInst])
-> (HomeModInfo -> ModDetails) -> HomeModInfo -> [FamInst]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeModInfo -> ModDetails
hm_details
; hpt_fam_insts :: ModuleEnv FamInstEnv
hpt_fam_insts = [(Module, FamInstEnv)] -> ModuleEnv FamInstEnv
forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv [ (HomeModInfo -> Module
hmiModule HomeModInfo
hmi, HomeModInfo -> FamInstEnv
hmiFamInstEnv HomeModInfo
hmi)
| HomePackageTable
hpt <- HomeUnitGraph -> [HomePackageTable]
unitEnv_hpts HomeUnitGraph
hug
, HomeModInfo
hmi <- HomePackageTable -> [HomeModInfo]
eltsHpt HomePackageTable
hpt ]
}
; ModuleEnv FamInstEnv -> (Module -> [Module]) -> [Module] -> TcM ()
checkMany ModuleEnv FamInstEnv
hpt_fam_insts Module -> [Module]
modConsistent [Module]
directlyImpMods
}
where
checkMany
:: ModuleEnv FamInstEnv
-> (Module -> [Module])
-> [Module]
-> TcM ()
checkMany :: ModuleEnv FamInstEnv -> (Module -> [Module]) -> [Module] -> TcM ()
checkMany ModuleEnv FamInstEnv
hpt_fam_insts Module -> [Module]
modConsistent [Module]
mods = [Module] -> ModuleSet -> [Module] -> TcM ()
go [] ModuleSet
emptyModuleSet [Module]
mods
where
go :: [Module]
-> ModuleSet
-> [Module]
-> TcM ()
go :: [Module] -> ModuleSet -> [Module] -> TcM ()
go [Module]
_ ModuleSet
_ [] = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go [Module]
consistent ModuleSet
consistent_set (Module
mod:[Module]
mods) = do
[TcM ()] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
[ ModuleEnv FamInstEnv -> Module -> Module -> TcM ()
check ModuleEnv FamInstEnv
hpt_fam_insts Module
m1 Module
m2
| Module
m1 <- [Module]
to_check_from_mod
, Module
m2 <- [Module]
to_check_from_consistent
]
[Module] -> ModuleSet -> [Module] -> TcM ()
go [Module]
consistent' ModuleSet
consistent_set' [Module]
mods
where
mod_deps_consistent :: [Module]
mod_deps_consistent = Module -> [Module]
modConsistent Module
mod
mod_deps_consistent_set :: ModuleSet
mod_deps_consistent_set = [Module] -> ModuleSet
mkModuleSet [Module]
mod_deps_consistent
consistent' :: [Module]
consistent' = [Module]
to_check_from_mod [Module] -> [Module] -> [Module]
forall a. [a] -> [a] -> [a]
++ [Module]
consistent
consistent_set' :: ModuleSet
consistent_set' =
ModuleSet -> [Module] -> ModuleSet
extendModuleSetList ModuleSet
consistent_set [Module]
to_check_from_mod
to_check_from_consistent :: [Module]
to_check_from_consistent =
(Module -> WhetherHasFamInst) -> [Module] -> [Module]
forall a. (a -> WhetherHasFamInst) -> [a] -> [a]
filterOut (Module -> ModuleSet -> WhetherHasFamInst
`elemModuleSet` ModuleSet
mod_deps_consistent_set) [Module]
consistent
to_check_from_mod :: [Module]
to_check_from_mod =
(Module -> WhetherHasFamInst) -> [Module] -> [Module]
forall a. (a -> WhetherHasFamInst) -> [a] -> [a]
filterOut (Module -> ModuleSet -> WhetherHasFamInst
`elemModuleSet` ModuleSet
consistent_set) [Module]
mod_deps_consistent
check :: ModuleEnv FamInstEnv -> Module -> Module -> TcM ()
check ModuleEnv FamInstEnv
hpt_fam_insts Module
m1 Module
m2
= do { FamInstEnv
env1' <- ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts ModuleEnv FamInstEnv
hpt_fam_insts Module
m1
; FamInstEnv
env2' <- ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts ModuleEnv FamInstEnv
hpt_fam_insts Module
m2
; let sizeE1 :: Int
sizeE1 = FamInstEnv -> Int
famInstEnvSize FamInstEnv
env1'
sizeE2 :: Int
sizeE2 = FamInstEnv -> Int
famInstEnvSize FamInstEnv
env2'
(FamInstEnv
env1, FamInstEnv
env2) = if Int
sizeE1 Int -> Int -> WhetherHasFamInst
forall a. Ord a => a -> a -> WhetherHasFamInst
< Int
sizeE2 then (FamInstEnv
env1', FamInstEnv
env2')
else (FamInstEnv
env2', FamInstEnv
env1')
; let check_now :: [FamInst]
check_now = FamInstEnv -> [FamInst]
famInstEnvElts FamInstEnv
env1
; (FamInst -> TcM ()) -> [FamInst] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForConflicts (FamInstEnv
emptyFamInstEnv, FamInstEnv
env2)) [FamInst]
check_now
; (FamInst -> TcM ()) -> [FamInst] -> TcM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForInjectivityConflicts (FamInstEnv
emptyFamInstEnv,FamInstEnv
env2)) [FamInst]
check_now
}
getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv
getFamInsts ModuleEnv FamInstEnv
hpt_fam_insts Module
mod
| Just FamInstEnv
env <- ModuleEnv FamInstEnv -> Module -> Maybe FamInstEnv
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv FamInstEnv
hpt_fam_insts Module
mod = FamInstEnv -> TcM FamInstEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return FamInstEnv
env
| WhetherHasFamInst
otherwise = do { ModIface
_ <- IfG ModIface -> TcRn ModIface
forall a. IfG a -> TcRn a
initIfaceTcRn (SDoc -> Module -> IfG ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadSysInterface SDoc
doc Module
mod)
; ExternalPackageState
eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; FamInstEnv -> TcM FamInstEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe FamInstEnv -> FamInstEnv
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"checkFamInstConsistency" (Maybe FamInstEnv -> FamInstEnv) -> Maybe FamInstEnv -> FamInstEnv
forall a b. (a -> b) -> a -> b
$
ModuleEnv FamInstEnv -> Module -> Maybe FamInstEnv
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv (ExternalPackageState -> ModuleEnv FamInstEnv
eps_mod_fam_inst_env ExternalPackageState
eps) Module
mod) }
where
doc :: SDoc
doc = Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is a family-instance module"
tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)
tcInstNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe = TyCon -> [Type] -> Maybe (Type, TcCoercion)
instNewTyCon_maybe
tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]
-> (TyCon, [TcType], Coercion)
tcLookupDataFamInst :: (FamInstEnv, FamInstEnv)
-> TyCon -> [Type] -> (TyCon, [Type], TcCoercion)
tcLookupDataFamInst (FamInstEnv, FamInstEnv)
fam_inst_envs TyCon
tc [Type]
tc_args
| Just (TyCon
rep_tc, [Type]
rep_args, TcCoercion
co)
<- (FamInstEnv, FamInstEnv)
-> TyCon -> [Type] -> Maybe (TyCon, [Type], TcCoercion)
tcLookupDataFamInst_maybe (FamInstEnv, FamInstEnv)
fam_inst_envs TyCon
tc [Type]
tc_args
= (TyCon
rep_tc, [Type]
rep_args, TcCoercion
co)
| WhetherHasFamInst
otherwise
= (TyCon
tc, [Type]
tc_args, Type -> TcCoercion
mkRepReflCo (TyCon -> [Type] -> Type
mkTyConApp TyCon
tc [Type]
tc_args))
tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]
-> Maybe (TyCon, [TcType], Coercion)
tcLookupDataFamInst_maybe :: (FamInstEnv, FamInstEnv)
-> TyCon -> [Type] -> Maybe (TyCon, [Type], TcCoercion)
tcLookupDataFamInst_maybe (FamInstEnv, FamInstEnv)
fam_inst_envs TyCon
tc [Type]
tc_args
| TyCon -> WhetherHasFamInst
isDataFamilyTyCon TyCon
tc
, FamInstMatch
match : [FamInstMatch]
_ <- (FamInstEnv, FamInstEnv) -> TyCon -> [Type] -> [FamInstMatch]
lookupFamInstEnv (FamInstEnv, FamInstEnv)
fam_inst_envs TyCon
tc [Type]
tc_args
, FamInstMatch { fim_instance :: FamInstMatch -> FamInst
fim_instance = rep_fam :: FamInst
rep_fam@(FamInst { fi_axiom :: FamInst -> CoAxiom Unbranched
fi_axiom = CoAxiom Unbranched
ax
, fi_cvs :: FamInst -> [TyVar]
fi_cvs = [TyVar]
cvs })
, fim_tys :: FamInstMatch -> [Type]
fim_tys = [Type]
rep_args
, fim_cos :: FamInstMatch -> [TcCoercion]
fim_cos = [TcCoercion]
rep_cos } <- FamInstMatch
match
, let rep_tc :: TyCon
rep_tc = FamInst -> TyCon
dataFamInstRepTyCon FamInst
rep_fam
co :: TcCoercion
co = Role -> CoAxiom Unbranched -> [Type] -> [TcCoercion] -> TcCoercion
mkUnbranchedAxInstCo Role
Representational CoAxiom Unbranched
ax [Type]
rep_args
([TyVar] -> [TcCoercion]
mkCoVarCos [TyVar]
cvs)
= WhetherHasFamInst
-> Maybe (TyCon, [Type], TcCoercion)
-> Maybe (TyCon, [Type], TcCoercion)
forall a. HasCallStack => WhetherHasFamInst -> a -> a
assert ([TcCoercion] -> WhetherHasFamInst
forall a. [a] -> WhetherHasFamInst
forall (t :: * -> *) a. Foldable t => t a -> WhetherHasFamInst
null [TcCoercion]
rep_cos) (Maybe (TyCon, [Type], TcCoercion)
-> Maybe (TyCon, [Type], TcCoercion))
-> Maybe (TyCon, [Type], TcCoercion)
-> Maybe (TyCon, [Type], TcCoercion)
forall a b. (a -> b) -> a -> b
$
(TyCon, [Type], TcCoercion) -> Maybe (TyCon, [Type], TcCoercion)
forall a. a -> Maybe a
Just (TyCon
rep_tc, [Type]
rep_args, TcCoercion
co)
| WhetherHasFamInst
otherwise
= Maybe (TyCon, [Type], TcCoercion)
forall a. Maybe a
Nothing
tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs
-> GlobalRdrEnv
-> Type
-> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
tcTopNormaliseNewTypeTF_maybe :: (FamInstEnv, FamInstEnv)
-> GlobalRdrEnv
-> Type
-> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
tcTopNormaliseNewTypeTF_maybe (FamInstEnv, FamInstEnv)
faminsts GlobalRdrEnv
rdr_env Type
ty
= NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
-> ((Bag GlobalRdrElt, TcCoercion)
-> (Bag GlobalRdrElt, TcCoercion)
-> (Bag GlobalRdrElt, TcCoercion))
-> Type
-> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)
forall ev.
NormaliseStepper ev -> (ev -> ev -> ev) -> Type -> Maybe (ev, Type)
topNormaliseTypeX NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
stepper (Bag GlobalRdrElt, TcCoercion)
-> (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
plus Type
ty
where
plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
-> (Bag GlobalRdrElt, TcCoercion)
plus :: (Bag GlobalRdrElt, TcCoercion)
-> (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)
plus (Bag GlobalRdrElt
gres1, TcCoercion
co1) (Bag GlobalRdrElt
gres2, TcCoercion
co2) = ( Bag GlobalRdrElt
gres1 Bag GlobalRdrElt -> Bag GlobalRdrElt -> Bag GlobalRdrElt
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag GlobalRdrElt
gres2
, TcCoercion
co1 TcCoercion -> TcCoercion -> TcCoercion
`mkTransCo` TcCoercion
co2 )
stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
stepper = NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
unwrap_newtype NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
-> NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
-> NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
forall ev.
NormaliseStepper ev -> NormaliseStepper ev -> NormaliseStepper ev
`composeSteppers` NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
unwrap_newtype_instance
unwrap_newtype_instance :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
unwrap_newtype_instance RecTcChecker
rec_nts TyCon
tc [Type]
tys
| Just (TyCon
tc', [Type]
tys', TcCoercion
co) <- (FamInstEnv, FamInstEnv)
-> TyCon -> [Type] -> Maybe (TyCon, [Type], TcCoercion)
tcLookupDataFamInst_maybe (FamInstEnv, FamInstEnv)
faminsts TyCon
tc [Type]
tys
= ((Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion))
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
forall ev1 ev2.
(ev1 -> ev2) -> NormaliseStepResult ev1 -> NormaliseStepResult ev2
mapStepResult (\(Bag GlobalRdrElt
gres, TcCoercion
co1) -> (Bag GlobalRdrElt
gres, TcCoercion
co TcCoercion -> TcCoercion -> TcCoercion
`mkTransCo` TcCoercion
co1)) (NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion))
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
forall a b. (a -> b) -> a -> b
$
NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
unwrap_newtype RecTcChecker
rec_nts TyCon
tc' [Type]
tys'
| WhetherHasFamInst
otherwise = NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
forall ev. NormaliseStepResult ev
NS_Done
unwrap_newtype :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)
unwrap_newtype RecTcChecker
rec_nts TyCon
tc [Type]
tys
| Just DataCon
con <- TyCon -> Maybe DataCon
newTyConDataCon_maybe TyCon
tc
, Just GlobalRdrElt
gre <- GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
lookupGRE_Name GlobalRdrEnv
rdr_env (DataCon -> Name
dataConName DataCon
con)
= (TcCoercion -> (Bag GlobalRdrElt, TcCoercion))
-> NormaliseStepResult TcCoercion
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
forall ev1 ev2.
(ev1 -> ev2) -> NormaliseStepResult ev1 -> NormaliseStepResult ev2
mapStepResult (\TcCoercion
co -> (GlobalRdrElt -> Bag GlobalRdrElt
forall a. a -> Bag a
unitBag GlobalRdrElt
gre, TcCoercion
co)) (NormaliseStepResult TcCoercion
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion))
-> NormaliseStepResult TcCoercion
-> NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
forall a b. (a -> b) -> a -> b
$
NormaliseStepper TcCoercion
unwrapNewTypeStepper RecTcChecker
rec_nts TyCon
tc [Type]
tys
| WhetherHasFamInst
otherwise
= NormaliseStepResult (Bag GlobalRdrElt, TcCoercion)
forall ev. NormaliseStepResult ev
NS_Done
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv :: forall a. [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv [] TcM a
thing_inside = TcM a
thing_inside
tcExtendLocalFamInstEnv [FamInst]
fam_insts TcM a
thing_inside
= do {
[FamInst] -> TcM ()
loadDependentFamInstModules [FamInst]
fam_insts
; TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (FamInstEnv
inst_env', [FamInst]
fam_insts') <- ((FamInstEnv, [FamInst])
-> FamInst
-> IOEnv (Env TcGblEnv TcLclEnv) (FamInstEnv, [FamInst]))
-> (FamInstEnv, [FamInst])
-> [FamInst]
-> IOEnv (Env TcGblEnv TcLclEnv) (FamInstEnv, [FamInst])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (FamInstEnv, [FamInst])
-> FamInst -> IOEnv (Env TcGblEnv TcLclEnv) (FamInstEnv, [FamInst])
addLocalFamInst
(TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
env, TcGblEnv -> [FamInst]
tcg_fam_insts TcGblEnv
env)
[FamInst]
fam_insts
; let env' :: TcGblEnv
env' = TcGblEnv
env { tcg_fam_insts :: [FamInst]
tcg_fam_insts = [FamInst]
fam_insts'
, tcg_fam_inst_env :: FamInstEnv
tcg_fam_inst_env = FamInstEnv
inst_env' }
; TcGblEnv -> TcM a -> TcM a
forall gbl' lcl a gbl.
gbl' -> TcRnIf gbl' lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' TcM a
thing_inside
}
loadDependentFamInstModules :: [FamInst] -> TcM ()
loadDependentFamInstModules :: [FamInst] -> TcM ()
loadDependentFamInstModules [FamInst]
fam_insts
= do { TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let this_mod :: Module
this_mod = TcGblEnv -> Module
tcg_mod TcGblEnv
env
imports :: ImportAvails
imports = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
env
want_module :: Module -> WhetherHasFamInst
want_module Module
mod
| Module
mod Module -> Module -> WhetherHasFamInst
forall a. Eq a => a -> a -> WhetherHasFamInst
== Module
this_mod = WhetherHasFamInst
False
| WhetherHasFamInst
home_fams_only = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod Unit -> Unit -> WhetherHasFamInst
forall a. Eq a => a -> a -> WhetherHasFamInst
== Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_mod
| WhetherHasFamInst
otherwise = WhetherHasFamInst
True
home_fams_only :: WhetherHasFamInst
home_fams_only = (FamInst -> WhetherHasFamInst) -> [FamInst] -> WhetherHasFamInst
forall (t :: * -> *) a.
Foldable t =>
(a -> WhetherHasFamInst) -> t a -> WhetherHasFamInst
all (Module -> Name -> WhetherHasFamInst
nameIsHomePackage Module
this_mod (Name -> WhetherHasFamInst)
-> (FamInst -> Name) -> FamInst -> WhetherHasFamInst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> Name
fi_fam) [FamInst]
fam_insts
; SDoc -> [Module] -> TcM ()
loadModuleInterfaces (String -> SDoc
text String
"Loading family-instance modules") ([Module] -> TcM ()) -> [Module] -> TcM ()
forall a b. (a -> b) -> a -> b
$
(Module -> WhetherHasFamInst) -> [Module] -> [Module]
forall a. (a -> WhetherHasFamInst) -> [a] -> [a]
filter Module -> WhetherHasFamInst
want_module (ImportAvails -> [Module]
imp_finsts ImportAvails
imports) }
addLocalFamInst :: (FamInstEnv,[FamInst])
-> FamInst
-> TcM (FamInstEnv, [FamInst])
addLocalFamInst :: (FamInstEnv, [FamInst])
-> FamInst -> IOEnv (Env TcGblEnv TcLclEnv) (FamInstEnv, [FamInst])
addLocalFamInst (FamInstEnv
home_fie, [FamInst]
my_fis) FamInst
fam_inst
= do { String -> SDoc -> TcM ()
traceTc String
"addLocalFamInst" (FamInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamInst
fam_inst)
; Module
mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; String -> SDoc -> TcM ()
traceTc String
"alfi" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod)
; ExternalPackageState
eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; let inst_envs :: (FamInstEnv, FamInstEnv)
inst_envs = (ExternalPackageState -> FamInstEnv
eps_fam_inst_env ExternalPackageState
eps, FamInstEnv
home_fie)
home_fie' :: FamInstEnv
home_fie' = FamInstEnv -> FamInst -> FamInstEnv
extendFamInstEnv FamInstEnv
home_fie FamInst
fam_inst
; ((), WhetherHasFamInst
no_errs) <- TcM () -> TcRn ((), WhetherHasFamInst)
forall a. TcRn a -> TcRn (a, WhetherHasFamInst)
askNoErrs (TcM () -> TcRn ((), WhetherHasFamInst))
-> TcM () -> TcRn ((), WhetherHasFamInst)
forall a b. (a -> b) -> a -> b
$
do { (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForConflicts (FamInstEnv, FamInstEnv)
inst_envs FamInst
fam_inst
; (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForInjectivityConflicts (FamInstEnv, FamInstEnv)
inst_envs FamInst
fam_inst
; FamInst -> TcM ()
checkInjectiveEquation FamInst
fam_inst
}
; if WhetherHasFamInst
no_errs then
(FamInstEnv, [FamInst])
-> IOEnv (Env TcGblEnv TcLclEnv) (FamInstEnv, [FamInst])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamInstEnv
home_fie', FamInst
fam_inst FamInst -> [FamInst] -> [FamInst]
forall a. a -> [a] -> [a]
: [FamInst]
my_fis)
else
(FamInstEnv, [FamInst])
-> IOEnv (Env TcGblEnv TcLclEnv) (FamInstEnv, [FamInst])
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FamInstEnv
home_fie, [FamInst]
my_fis) }
checkForConflicts :: FamInstEnvs -> FamInst -> TcM ()
checkForConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForConflicts (FamInstEnv, FamInstEnv)
inst_envs FamInst
fam_inst
= do { let conflicts :: [FamInst]
conflicts = (FamInstEnv, FamInstEnv) -> FamInst -> [FamInst]
lookupFamInstEnvConflicts (FamInstEnv, FamInstEnv)
inst_envs FamInst
fam_inst
; String -> SDoc -> TcM ()
traceTc String
"checkForConflicts" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat [ [FamInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [FamInst]
conflicts
, FamInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr FamInst
fam_inst
]
; FamInst -> [FamInst] -> TcM ()
reportConflictInstErr FamInst
fam_inst [FamInst]
conflicts }
checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM ()
checkForInjectivityConflicts :: (FamInstEnv, FamInstEnv) -> FamInst -> TcM ()
checkForInjectivityConflicts (FamInstEnv, FamInstEnv)
instEnvs FamInst
famInst
| TyCon -> WhetherHasFamInst
isTypeFamilyTyCon TyCon
tycon
, Injective [WhetherHasFamInst]
inj <- TyCon -> Injectivity
tyConInjectivityInfo TyCon
tycon
= let conflicts :: [CoAxBranch]
conflicts = [WhetherHasFamInst]
-> (FamInstEnv, FamInstEnv) -> FamInst -> [CoAxBranch]
lookupFamInstEnvInjectivityConflicts [WhetherHasFamInst]
inj (FamInstEnv, FamInstEnv)
instEnvs FamInst
famInst in
TyCon -> [CoAxBranch] -> CoAxBranch -> TcM ()
reportConflictingInjectivityErrs TyCon
tycon [CoAxBranch]
conflicts (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch (FamInst -> CoAxiom Unbranched
fi_axiom FamInst
famInst))
| WhetherHasFamInst
otherwise
= () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where tycon :: TyCon
tycon = FamInst -> TyCon
famInstTyCon FamInst
famInst
checkInjectiveEquation :: FamInst -> TcM ()
checkInjectiveEquation :: FamInst -> TcM ()
checkInjectiveEquation FamInst
famInst
| TyCon -> WhetherHasFamInst
isTypeFamilyTyCon TyCon
tycon
, Injective [WhetherHasFamInst]
inj <- TyCon -> Injectivity
tyConInjectivityInfo TyCon
tycon = do
{ DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let axiom :: CoAxBranch
axiom = CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
fi_ax
; DynFlags
-> CoAxiom Unbranched
-> CoAxBranch
-> [WhetherHasFamInst]
-> TcM ()
forall (br :: BranchFlag).
DynFlags
-> CoAxiom br -> CoAxBranch -> [WhetherHasFamInst] -> TcM ()
reportInjectivityErrors DynFlags
dflags CoAxiom Unbranched
fi_ax CoAxBranch
axiom [WhetherHasFamInst]
inj
}
| WhetherHasFamInst
otherwise
= () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where tycon :: TyCon
tycon = FamInst -> TyCon
famInstTyCon FamInst
famInst
fi_ax :: CoAxiom Unbranched
fi_ax = FamInst -> CoAxiom Unbranched
fi_axiom FamInst
famInst
reportInjectivityErrors
:: DynFlags
-> CoAxiom br
-> CoAxBranch
-> [Bool]
-> TcM ()
reportInjectivityErrors :: forall (br :: BranchFlag).
DynFlags
-> CoAxiom br -> CoAxBranch -> [WhetherHasFamInst] -> TcM ()
reportInjectivityErrors DynFlags
dflags CoAxiom br
fi_ax CoAxBranch
axiom [WhetherHasFamInst]
inj
= WhetherHasFamInst -> SDoc -> TcM () -> TcM ()
forall a. HasCallStack => WhetherHasFamInst -> SDoc -> a -> a
assertPpr ((WhetherHasFamInst -> WhetherHasFamInst)
-> [WhetherHasFamInst] -> WhetherHasFamInst
forall (t :: * -> *) a.
Foldable t =>
(a -> WhetherHasFamInst) -> t a -> WhetherHasFamInst
any WhetherHasFamInst -> WhetherHasFamInst
forall a. a -> a
id [WhetherHasFamInst]
inj) (String -> SDoc
text String
"No injective type variables") (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$
do let lhs :: [Type]
lhs = CoAxBranch -> [Type]
coAxBranchLHS CoAxBranch
axiom
rhs :: Type
rhs = CoAxBranch -> Type
coAxBranchRHS CoAxBranch
axiom
fam_tc :: TyCon
fam_tc = CoAxiom br -> TyCon
forall (br :: BranchFlag). CoAxiom br -> TyCon
coAxiomTyCon CoAxiom br
fi_ax
(TyVarSet
unused_inj_tvs, HasKinds
unused_vis, SuggestUndecidableInstances
undec_inst_flag)
= DynFlags
-> TyCon
-> [Type]
-> Type
-> (TyVarSet, HasKinds, SuggestUndecidableInstances)
unusedInjTvsInRHS DynFlags
dflags TyCon
fam_tc [Type]
lhs Type
rhs
inj_tvs_unused :: WhetherHasFamInst
inj_tvs_unused = WhetherHasFamInst -> WhetherHasFamInst
not (WhetherHasFamInst -> WhetherHasFamInst)
-> WhetherHasFamInst -> WhetherHasFamInst
forall a b. (a -> b) -> a -> b
$ TyVarSet -> WhetherHasFamInst
isEmptyVarSet TyVarSet
unused_inj_tvs
tf_headed :: WhetherHasFamInst
tf_headed = Type -> WhetherHasFamInst
isTFHeaded Type
rhs
bare_variables :: [Type]
bare_variables = [Type] -> Type -> [Type]
bareTvInRHSViolated [Type]
lhs Type
rhs
wrong_bare_rhs :: WhetherHasFamInst
wrong_bare_rhs = WhetherHasFamInst -> WhetherHasFamInst
not (WhetherHasFamInst -> WhetherHasFamInst)
-> WhetherHasFamInst -> WhetherHasFamInst
forall a b. (a -> b) -> a -> b
$ [Type] -> WhetherHasFamInst
forall a. [a] -> WhetherHasFamInst
forall (t :: * -> *) a. Foldable t => t a -> WhetherHasFamInst
null [Type]
bare_variables
WhetherHasFamInst -> TcM () -> TcM ()
forall (f :: * -> *).
Applicative f =>
WhetherHasFamInst -> f () -> f ()
when WhetherHasFamInst
inj_tvs_unused (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCon
-> TyVarSet
-> HasKinds
-> SuggestUndecidableInstances
-> CoAxBranch
-> TcM ()
reportUnusedInjectiveVarsErr TyCon
fam_tc TyVarSet
unused_inj_tvs
HasKinds
unused_vis SuggestUndecidableInstances
undec_inst_flag CoAxBranch
axiom
WhetherHasFamInst -> TcM () -> TcM ()
forall (f :: * -> *).
Applicative f =>
WhetherHasFamInst -> f () -> f ()
when WhetherHasFamInst
tf_headed (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> CoAxBranch -> TcM ()
reportTfHeadedErr TyCon
fam_tc CoAxBranch
axiom
WhetherHasFamInst -> TcM () -> TcM ()
forall (f :: * -> *).
Applicative f =>
WhetherHasFamInst -> f () -> f ()
when WhetherHasFamInst
wrong_bare_rhs (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ TyCon -> [Type] -> CoAxBranch -> TcM ()
reportBareVariableInRHSErr TyCon
fam_tc [Type]
bare_variables CoAxBranch
axiom
isTFHeaded :: Type -> Bool
isTFHeaded :: Type -> WhetherHasFamInst
isTFHeaded Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= Type -> WhetherHasFamInst
isTFHeaded Type
ty'
isTFHeaded Type
ty | (TyConApp TyCon
tc [Type]
args) <- Type
ty
, TyCon -> WhetherHasFamInst
isTypeFamilyTyCon TyCon
tc
= [Type]
args [Type] -> Int -> WhetherHasFamInst
forall a. [a] -> Int -> WhetherHasFamInst
`lengthIs` TyCon -> Int
tyConArity TyCon
tc
isTFHeaded Type
_ = WhetherHasFamInst
False
bareTvInRHSViolated :: [Type] -> Type -> [Type]
bareTvInRHSViolated :: [Type] -> Type -> [Type]
bareTvInRHSViolated [Type]
pats Type
rhs | Type -> WhetherHasFamInst
isTyVarTy Type
rhs
= (Type -> WhetherHasFamInst) -> [Type] -> [Type]
forall a. (a -> WhetherHasFamInst) -> [a] -> [a]
filter (WhetherHasFamInst -> WhetherHasFamInst
not (WhetherHasFamInst -> WhetherHasFamInst)
-> (Type -> WhetherHasFamInst) -> Type -> WhetherHasFamInst
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> WhetherHasFamInst
isTyVarTy) [Type]
pats
bareTvInRHSViolated [Type]
_ Type
_ = []
unusedInjTvsInRHS :: DynFlags
-> TyCon
-> [Type]
-> Type
-> ( TyVarSet
, HasKinds
, SuggestUndecidableInstances)
unusedInjTvsInRHS :: DynFlags
-> TyCon
-> [Type]
-> Type
-> (TyVarSet, HasKinds, SuggestUndecidableInstances)
unusedInjTvsInRHS DynFlags
dflags tycon :: TyCon
tycon@(TyCon -> Injectivity
tyConInjectivityInfo -> Injective [WhetherHasFamInst]
inj_list) [Type]
lhs Type
rhs =
(TyVarSet
bad_vars, WhetherHasFamInst -> HasKinds
hasKinds WhetherHasFamInst
any_invisible, WhetherHasFamInst -> SuggestUndecidableInstances
suggestUndecidableInstances WhetherHasFamInst
suggest_undec)
where
undec_inst :: WhetherHasFamInst
undec_inst = Extension -> DynFlags -> WhetherHasFamInst
xopt Extension
LangExt.UndecidableInstances DynFlags
dflags
inj_lhs :: [Type]
inj_lhs = [WhetherHasFamInst] -> [Type] -> [Type]
forall a. [WhetherHasFamInst] -> [a] -> [a]
filterByList [WhetherHasFamInst]
inj_list [Type]
lhs
lhs_vars :: TyVarSet
lhs_vars = [Type] -> TyVarSet
tyCoVarsOfTypes [Type]
inj_lhs
rhs_inj_vars :: TyVarSet
rhs_inj_vars = FV -> TyVarSet
fvVarSet (FV -> TyVarSet) -> FV -> TyVarSet
forall a b. (a -> b) -> a -> b
$ WhetherHasFamInst -> Type -> FV
injectiveVarsOfType WhetherHasFamInst
undec_inst Type
rhs
bad_vars :: TyVarSet
bad_vars = TyVarSet
lhs_vars TyVarSet -> TyVarSet -> TyVarSet
`minusVarSet` TyVarSet
rhs_inj_vars
any_bad :: WhetherHasFamInst
any_bad = WhetherHasFamInst -> WhetherHasFamInst
not (WhetherHasFamInst -> WhetherHasFamInst)
-> WhetherHasFamInst -> WhetherHasFamInst
forall a b. (a -> b) -> a -> b
$ TyVarSet -> WhetherHasFamInst
isEmptyVarSet TyVarSet
bad_vars
invis_vars :: TyVarSet
invis_vars = FV -> TyVarSet
fvVarSet (FV -> TyVarSet) -> FV -> TyVarSet
forall a b. (a -> b) -> a -> b
$ [Type] -> FV
invisibleVarsOfTypes [TyCon -> [Type] -> Type
mkTyConApp TyCon
tycon [Type]
lhs, Type
rhs]
any_invisible :: WhetherHasFamInst
any_invisible = WhetherHasFamInst
any_bad WhetherHasFamInst -> WhetherHasFamInst -> WhetherHasFamInst
&& (TyVarSet
bad_vars TyVarSet -> TyVarSet -> WhetherHasFamInst
`intersectsVarSet` TyVarSet
invis_vars)
suggest_undec :: WhetherHasFamInst
suggest_undec = WhetherHasFamInst
any_bad WhetherHasFamInst -> WhetherHasFamInst -> WhetherHasFamInst
&&
WhetherHasFamInst -> WhetherHasFamInst
not WhetherHasFamInst
undec_inst WhetherHasFamInst -> WhetherHasFamInst -> WhetherHasFamInst
&&
(TyVarSet
lhs_vars TyVarSet -> TyVarSet -> WhetherHasFamInst
`subVarSet` FV -> TyVarSet
fvVarSet (WhetherHasFamInst -> Type -> FV
injectiveVarsOfType WhetherHasFamInst
True Type
rhs))
unusedInjTvsInRHS DynFlags
_ TyCon
_ [Type]
_ Type
_ = (TyVarSet
emptyVarSet, HasKinds
NoHasKinds, SuggestUndecidableInstances
NoSuggestUndecidableInstaces)
reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM ()
reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM ()
reportConflictingInjectivityErrs TyCon
_ [] CoAxBranch
_ = () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reportConflictingInjectivityErrs TyCon
fam_tc (CoAxBranch
confEqn1:[CoAxBranch]
_) CoAxBranch
tyfamEqn
= [(SrcSpan, TcRnMessage)] -> TcM ()
addErrs [(TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-> TyCon -> NonEmpty CoAxBranch -> (SrcSpan, TcRnMessage)
buildInjectivityError (InjectivityErrReason -> TyCon -> NonEmpty CoAxBranch -> TcRnMessage
TcRnFamInstNotInjective InjectivityErrReason
InjErrRhsOverlap)
TyCon
fam_tc
(CoAxBranch
confEqn1 CoAxBranch -> [CoAxBranch] -> NonEmpty CoAxBranch
forall a. a -> [a] -> NonEmpty a
:| [CoAxBranch
tyfamEqn])]
reportUnusedInjectiveVarsErr :: TyCon
-> TyVarSet
-> HasKinds
-> SuggestUndecidableInstances
-> CoAxBranch
-> TcM ()
reportUnusedInjectiveVarsErr :: TyCon
-> TyVarSet
-> HasKinds
-> SuggestUndecidableInstances
-> CoAxBranch
-> TcM ()
reportUnusedInjectiveVarsErr TyCon
fam_tc TyVarSet
tvs HasKinds
has_kinds SuggestUndecidableInstances
undec_inst CoAxBranch
tyfamEqn
= let reason :: InjectivityErrReason
reason = TyVarSet
-> HasKinds -> SuggestUndecidableInstances -> InjectivityErrReason
InjErrCannotInferFromRhs TyVarSet
tvs HasKinds
has_kinds SuggestUndecidableInstances
undec_inst
(SrcSpan
loc, TcRnMessage
dia) = (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-> TyCon -> NonEmpty CoAxBranch -> (SrcSpan, TcRnMessage)
buildInjectivityError (InjectivityErrReason -> TyCon -> NonEmpty CoAxBranch -> TcRnMessage
TcRnFamInstNotInjective InjectivityErrReason
reason) TyCon
fam_tc (CoAxBranch
tyfamEqn CoAxBranch -> [CoAxBranch] -> NonEmpty CoAxBranch
forall a. a -> [a] -> NonEmpty a
:| [])
in SrcSpan -> TcRnMessage -> TcM ()
addErrAt SrcSpan
loc TcRnMessage
dia
reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM ()
reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM ()
reportTfHeadedErr TyCon
fam_tc CoAxBranch
branch
= [(SrcSpan, TcRnMessage)] -> TcM ()
addErrs [(TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-> TyCon -> NonEmpty CoAxBranch -> (SrcSpan, TcRnMessage)
buildInjectivityError (InjectivityErrReason -> TyCon -> NonEmpty CoAxBranch -> TcRnMessage
TcRnFamInstNotInjective InjectivityErrReason
InjErrRhsCannotBeATypeFam)
TyCon
fam_tc
(CoAxBranch
branch CoAxBranch -> [CoAxBranch] -> NonEmpty CoAxBranch
forall a. a -> [a] -> NonEmpty a
:| [])]
reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM ()
reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM ()
reportBareVariableInRHSErr TyCon
fam_tc [Type]
tys CoAxBranch
branch
= [(SrcSpan, TcRnMessage)] -> TcM ()
addErrs [(TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-> TyCon -> NonEmpty CoAxBranch -> (SrcSpan, TcRnMessage)
buildInjectivityError (InjectivityErrReason -> TyCon -> NonEmpty CoAxBranch -> TcRnMessage
TcRnFamInstNotInjective ([Type] -> InjectivityErrReason
InjErrRhsBareTyVar [Type]
tys))
TyCon
fam_tc
(CoAxBranch
branch CoAxBranch -> [CoAxBranch] -> NonEmpty CoAxBranch
forall a. a -> [a] -> NonEmpty a
:| [])]
buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-> TyCon
-> NonEmpty CoAxBranch
-> (SrcSpan, TcRnMessage)
buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)
-> TyCon -> NonEmpty CoAxBranch -> (SrcSpan, TcRnMessage)
buildInjectivityError TyCon -> NonEmpty CoAxBranch -> TcRnMessage
mkErr TyCon
fam_tc NonEmpty CoAxBranch
branches
= ( CoAxBranch -> SrcSpan
coAxBranchSpan (NonEmpty CoAxBranch -> CoAxBranch
forall a. NonEmpty a -> a
NE.head NonEmpty CoAxBranch
branches), TyCon -> NonEmpty CoAxBranch -> TcRnMessage
mkErr TyCon
fam_tc NonEmpty CoAxBranch
branches )
reportConflictInstErr :: FamInst -> [FamInst] -> TcRn ()
reportConflictInstErr :: FamInst -> [FamInst] -> TcM ()
reportConflictInstErr FamInst
_ []
= () -> TcM ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
reportConflictInstErr FamInst
fam_inst (FamInst
conf_inst : [FamInst]
_) =
let sorted :: NonEmpty FamInst
sorted = (FamInst -> FamInst -> Ordering)
-> NonEmpty FamInst -> NonEmpty FamInst
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy (SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest (SrcSpan -> SrcSpan -> Ordering)
-> (FamInst -> SrcSpan) -> FamInst -> FamInst -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` FamInst -> SrcSpan
getSpan) (FamInst
fam_inst FamInst -> [FamInst] -> NonEmpty FamInst
forall a. a -> [a] -> NonEmpty a
NE.:| [FamInst
conf_inst])
fi1 :: FamInst
fi1 = NonEmpty FamInst -> FamInst
forall a. NonEmpty a -> a
NE.head NonEmpty FamInst
sorted
span :: SrcSpan
span = CoAxBranch -> SrcSpan
coAxBranchSpan (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch (FamInst -> CoAxiom Unbranched
famInstAxiom FamInst
fi1))
getSpan :: FamInst -> SrcSpan
getSpan = CoAxiom Unbranched -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan (CoAxiom Unbranched -> SrcSpan)
-> (FamInst -> CoAxiom Unbranched) -> FamInst -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> CoAxiom Unbranched
famInstAxiom
in SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
span (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcM ()
addErr (TcRnMessage -> TcM ()) -> TcRnMessage -> TcM ()
forall a b. (a -> b) -> a -> b
$ NonEmpty FamInst -> TcRnMessage
TcRnConflictingFamInstDecls NonEmpty FamInst
sorted
tcGetFamInstEnvs :: TcM FamInstEnvs
tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
tcGetFamInstEnvs
= do { ExternalPackageState
eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps; TcGblEnv
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (FamInstEnv, FamInstEnv) -> TcM (FamInstEnv, FamInstEnv)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExternalPackageState -> FamInstEnv
eps_fam_inst_env ExternalPackageState
eps, TcGblEnv -> FamInstEnv
tcg_fam_inst_env TcGblEnv
env) }