{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.TyCl.Utils(
RolesInfo,
inferRoles,
checkSynCycles,
checkClassCycles,
addTyConsToGblEnv, mkDefaultMethodType,
tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
) where
import GHC.Prelude
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Bind( tcValBinds )
import GHC.Tc.Utils.TcType
import GHC.Builtin.Types( unitTy )
import GHC.Builtin.Uniques ( mkBuiltinUnique )
import GHC.Hs
import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Core.Make( rEC_SEL_ERROR_ID )
import GHC.Core.Class
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon.Set
import GHC.Core.Coercion ( ltRole )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
import GHC.Utils.FV as FV
import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Unit.Module
import GHC.Types.Basic
import GHC.Types.Error
import GHC.Types.FieldLabel
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Reader ( mkVarUnqual )
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Unique.Set
import GHC.Types.TyThing
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
synonymTyConsOfType :: Type -> [TyCon]
synonymTyConsOfType :: Type -> [TyCon]
synonymTyConsOfType Type
ty
= NameEnv TyCon -> [TyCon]
forall a. NameEnv a -> [a]
nonDetNameEnvElts (Type -> NameEnv TyCon
go Type
ty)
where
go :: Type -> NameEnv TyCon
go :: Type -> NameEnv TyCon
go (TyConApp TyCon
tc [Type]
tys) = TyCon -> NameEnv TyCon
go_tc TyCon
tc NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` [Type] -> NameEnv TyCon
forall (t :: * -> *). Foldable t => t Type -> NameEnv TyCon
go_s [Type]
tys
go (LitTy TyLit
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go (TyVarTy Var
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go (AppTy Type
a Type
b) = Type -> NameEnv TyCon
go Type
a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
b
go (FunTy AnonArgFlag
_ Type
w Type
a Type
b) = Type -> NameEnv TyCon
go Type
w NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
b
go (ForAllTy TyCoVarBinder
_ Type
ty) = Type -> NameEnv TyCon
go Type
ty
go (CastTy Type
ty KindCoercion
co) = Type -> NameEnv TyCon
go Type
ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go (CoercionTy KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_mco :: MCoercionN -> NameEnv TyCon
go_mco MCoercionN
MRefl = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_mco (MCo KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_co :: KindCoercion -> NameEnv TyCon
go_co (Refl Type
ty) = Type -> NameEnv TyCon
go Type
ty
go_co (GRefl Role
_ Type
ty MCoercionN
mco) = Type -> NameEnv TyCon
go Type
ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` MCoercionN -> NameEnv TyCon
go_mco MCoercionN
mco
go_co (TyConAppCo Role
_ TyCon
tc [KindCoercion]
cs) = TyCon -> NameEnv TyCon
go_tc TyCon
tc NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cs
go_co (AppCo KindCoercion
co KindCoercion
co') = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
go_co (ForAllCo Var
_ KindCoercion
co KindCoercion
co') = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
go_co (FunCo Role
_ KindCoercion
co_mult KindCoercion
co KindCoercion
co') = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co_mult NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
go_co (CoVarCo Var
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_co (HoleCo {}) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_co (AxiomInstCo CoAxiom Branched
_ BranchIndex
_ [KindCoercion]
cs) = [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cs
go_co (UnivCo UnivCoProvenance
p Role
_ Type
ty Type
ty') = UnivCoProvenance -> NameEnv TyCon
go_prov UnivCoProvenance
p NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
ty'
go_co (SymCo KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_co (TransCo KindCoercion
co KindCoercion
co') = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
go_co (NthCo Role
_ BranchIndex
_ KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_co (LRCo LeftOrRight
_ KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_co (InstCo KindCoercion
co KindCoercion
co') = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
go_co (KindCo KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_co (SubCo KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_co (AxiomRuleCo CoAxiomRule
_ [KindCoercion]
cs) = [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cs
go_prov :: UnivCoProvenance -> NameEnv TyCon
go_prov (PhantomProv KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_prov (ProofIrrelProv KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
go_prov (PluginProv String
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_prov (CorePrepProv Bool
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_tc :: TyCon -> NameEnv TyCon
go_tc TyCon
tc | TyCon -> Bool
isTypeSynonymTyCon TyCon
tc = Name -> TyCon -> NameEnv TyCon
forall a. Name -> a -> NameEnv a
unitNameEnv (TyCon -> Name
tyConName TyCon
tc) TyCon
tc
| Bool
otherwise = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_s :: t Type -> NameEnv TyCon
go_s t Type
tys = (Type -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> t Type -> NameEnv TyCon
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon)
-> (Type -> NameEnv TyCon)
-> Type
-> NameEnv TyCon
-> NameEnv TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NameEnv TyCon
go) NameEnv TyCon
forall a. NameEnv a
emptyNameEnv t Type
tys
go_co_s :: [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cos = (KindCoercion -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> [KindCoercion] -> NameEnv TyCon
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon)
-> (KindCoercion -> NameEnv TyCon)
-> KindCoercion
-> NameEnv TyCon
-> NameEnv TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindCoercion -> NameEnv TyCon
go_co) NameEnv TyCon
forall a. NameEnv a
emptyNameEnv [KindCoercion]
cos
newtype SynCycleM a = SynCycleM {
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
deriving (a -> SynCycleM b -> SynCycleM a
(a -> b) -> SynCycleM a -> SynCycleM b
(forall a b. (a -> b) -> SynCycleM a -> SynCycleM b)
-> (forall a b. a -> SynCycleM b -> SynCycleM a)
-> Functor SynCycleM
forall a b. a -> SynCycleM b -> SynCycleM a
forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SynCycleM b -> SynCycleM a
$c<$ :: forall a b. a -> SynCycleM b -> SynCycleM a
fmap :: (a -> b) -> SynCycleM a -> SynCycleM b
$cfmap :: forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
Functor)
type SynCycleState = TyConSet
instance Applicative SynCycleM where
pure :: a -> SynCycleM a
pure a
x = (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a)
-> (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
forall a b. (a -> b) -> a -> b
$ \SynCycleState
state -> (a, SynCycleState) -> Either (SrcSpan, SDoc) (a, SynCycleState)
forall a b. b -> Either a b
Right (a
x, SynCycleState
state)
<*> :: SynCycleM (a -> b) -> SynCycleM a -> SynCycleM b
(<*>) = SynCycleM (a -> b) -> SynCycleM a -> SynCycleM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad SynCycleM where
SynCycleM a
m >>= :: SynCycleM a -> (a -> SynCycleM b) -> SynCycleM b
>>= a -> SynCycleM b
f = (SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState))
-> SynCycleM b
forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState))
-> SynCycleM b)
-> (SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState))
-> SynCycleM b
forall a b. (a -> b) -> a -> b
$ \SynCycleState
state ->
case SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM SynCycleM a
m SynCycleState
state of
Right (a
x, SynCycleState
state') ->
SynCycleM b
-> SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState)
forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM (a -> SynCycleM b
f a
x) SynCycleState
state'
Left (SrcSpan, SDoc)
err -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (b, SynCycleState)
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM SrcSpan
loc SDoc
err = (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
-> SynCycleM ()
forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
-> SynCycleM ())
-> (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
-> SynCycleM ()
forall a b. (a -> b) -> a -> b
$ \SynCycleState
_ -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a b. a -> Either a b
Left (SrcSpan
loc, SDoc
err)
checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic TyCon
tc SynCycleM ()
m = (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
-> SynCycleM ()
forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
-> SynCycleM ())
-> (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
-> SynCycleM ()
forall a b. (a -> b) -> a -> b
$ \SynCycleState
s ->
if TyCon
tc TyCon -> SynCycleState -> Bool
`elemTyConSet` SynCycleState
s
then ((), SynCycleState) -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a b. b -> Either a b
Right ((), SynCycleState
s)
else case SynCycleM ()
-> SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM SynCycleM ()
m SynCycleState
s of
Right ((), SynCycleState
s') -> ((), SynCycleState) -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a b. b -> Either a b
Right ((), SynCycleState -> TyCon -> SynCycleState
extendTyConSet SynCycleState
s' TyCon
tc)
Left (SrcSpan, SDoc)
err -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles Unit
this_uid [TyCon]
tcs [LTyClDecl GhcRn]
tyclds =
case SynCycleM ()
-> SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM ((TyCon -> SynCycleM ()) -> [TyCon] -> SynCycleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go SynCycleState
emptyTyConSet []) [TyCon]
tcs) SynCycleState
emptyTyConSet of
Left (SrcSpan
loc, SDoc
err) -> SrcSpan -> TcM () -> TcM ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcM () -> TcM ()) -> TcM () -> TcM ()
forall a b. (a -> b) -> a -> b
$ TcRnMessage -> TcM ()
forall a. TcRnMessage -> TcM a
failWithTc (DiagnosticMessage -> TcRnMessage
forall a. (Diagnostic a, Typeable a) => a -> TcRnMessage
TcRnUnknownMessage (DiagnosticMessage -> TcRnMessage)
-> DiagnosticMessage -> TcRnMessage
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints SDoc
err)
Right ((), SynCycleState)
_ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
lcl_decls :: NameEnv
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))
lcl_decls = [(Name,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))]
-> NameEnv
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([Name]
-> [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn)]
-> [(Name,
GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))]
forall a b. [a] -> [b] -> [(a, b)]
zip ((TyCon -> Name) -> [TyCon] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
tyConName [TyCon]
tcs) [LTyClDecl GhcRn]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn)]
tyclds)
go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc =
TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic TyCon
tc (SynCycleM () -> SynCycleM ()) -> SynCycleM () -> SynCycleM ()
forall a b. (a -> b) -> a -> b
$ SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go' SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc
go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
go' :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go' SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc
| TyCon
tc TyCon -> SynCycleState -> Bool
`elemTyConSet` SynCycleState
so_far
= SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM (TyCon -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan ([TyCon] -> TyCon
forall a. [a] -> a
head [TyCon]
seen_tcs)) (SDoc -> SynCycleM ()) -> SDoc -> SynCycleM ()
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ String -> SDoc
text String
"Cycle in type synonym declarations:"
, BranchIndex -> SDoc -> SDoc
nest BranchIndex
2 ([SDoc] -> SDoc
vcat ((TyCon -> SDoc) -> [TyCon] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
ppr_decl [TyCon]
seen_tcs)) ]
| Bool -> Bool
not (GenModule Unit -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule GenModule Unit
mod Bool -> Bool -> Bool
||
GenModule Unit -> Unit
forall unit. GenModule unit -> unit
moduleUnit GenModule Unit
mod Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== Unit
this_uid Bool -> Bool -> Bool
||
GenModule Unit -> Bool
isInteractiveModule GenModule Unit
mod)
= () -> SynCycleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just Type
ty <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc =
SynCycleState -> [TyCon] -> Type -> SynCycleM ()
go_ty (SynCycleState -> TyCon -> SynCycleState
extendTyConSet SynCycleState
so_far TyCon
tc) (TyCon
tcTyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
:[TyCon]
seen_tcs) Type
ty
| Bool
otherwise = () -> SynCycleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
n :: Name
n = TyCon -> Name
tyConName TyCon
tc
mod :: GenModule Unit
mod = HasDebugCallStack => Name -> GenModule Unit
Name -> GenModule Unit
nameModule Name
n
ppr_decl :: TyCon -> SDoc
ppr_decl TyCon
tc =
case NameEnv
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))
-> Name
-> Maybe
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))
lcl_decls Name
n of
Just (L SrcSpanAnn' (EpAnn AnnListItem)
loc TyClDecl GhcRn
decl) -> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (SrcSpanAnn' (EpAnn AnnListItem) -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' (EpAnn AnnListItem)
loc) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> TyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
decl
Maybe
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (TyClDecl GhcRn))
Nothing -> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"from external module"
where
n :: Name
n = TyCon -> Name
tyConName TyCon
tc
go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
go_ty :: SynCycleState -> [TyCon] -> Type -> SynCycleM ()
go_ty SynCycleState
so_far [TyCon]
seen_tcs Type
ty =
(TyCon -> SynCycleM ()) -> [TyCon] -> SynCycleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go SynCycleState
so_far [TyCon]
seen_tcs) (Type -> [TyCon]
synonymTyConsOfType Type
ty)
type ClassSet = UniqSet Class
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles Class
cls
= do { (Bool
definite_cycle, SDoc
err) <- ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go (Class -> ClassSet
forall a. Uniquable a => a -> UniqSet a
unitUniqSet Class
cls)
Class
cls ([Var] -> [Type]
mkTyVarTys (Class -> [Var]
classTyVars Class
cls))
; let herald :: SDoc
herald | Bool
definite_cycle = String -> SDoc
text String
"Superclass cycle for"
| Bool
otherwise = String -> SDoc
text String
"Potential superclass cycle for"
; SDoc -> Maybe SDoc
forall (m :: * -> *) a. Monad m => a -> m a
return ([SDoc] -> SDoc
vcat [ SDoc
herald SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
, BranchIndex -> SDoc -> SDoc
nest BranchIndex
2 SDoc
err, SDoc
hint]) }
where
hint :: SDoc
hint = String -> SDoc
text String
"Use UndecidableSuperClasses to accept this"
go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go ClassSet
so_far Class
cls [Type]
tys = [Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc)
forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts ([Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc))
-> [Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc)
forall a b. (a -> b) -> a -> b
$
(Type -> Maybe (Bool, SDoc)) -> [Type] -> [Maybe (Bool, SDoc)]
forall a b. (a -> b) -> [a] -> [b]
map (ClassSet -> Type -> Maybe (Bool, SDoc)
go_pred ClassSet
so_far) ([Type] -> [Maybe (Bool, SDoc)]) -> [Type] -> [Maybe (Bool, SDoc)]
forall a b. (a -> b) -> a -> b
$
Class -> [Type] -> [Type]
immSuperClasses Class
cls [Type]
tys
go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
go_pred :: ClassSet -> Type -> Maybe (Bool, SDoc)
go_pred ClassSet
so_far Type
pred
| Just (TyCon
tc, [Type]
tys) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
pred
= ClassSet -> Type -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc ClassSet
so_far Type
pred TyCon
tc [Type]
tys
| Type -> Bool
hasTyVarHead Type
pred
= (Bool, SDoc) -> Maybe (Bool, SDoc)
forall a. a -> Maybe a
Just (Bool
False, SDoc -> BranchIndex -> SDoc -> SDoc
hang (String -> SDoc
text String
"one of whose superclass constraints is headed by a type variable:")
BranchIndex
2 (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)))
| Bool
otherwise
= Maybe (Bool, SDoc)
forall a. Maybe a
Nothing
go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc :: ClassSet -> Type -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc ClassSet
so_far Type
pred TyCon
tc [Type]
tys
| TyCon -> Bool
isFamilyTyCon TyCon
tc
= (Bool, SDoc) -> Maybe (Bool, SDoc)
forall a. a -> Maybe a
Just (Bool
False, SDoc -> BranchIndex -> SDoc -> SDoc
hang (String -> SDoc
text String
"one of whose superclass constraints is headed by a type family:")
BranchIndex
2 (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)))
| Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
= ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls ClassSet
so_far Class
cls [Type]
tys
| Bool
otherwise
= Maybe (Bool, SDoc)
forall a. Maybe a
Nothing
go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls ClassSet
so_far Class
cls [Type]
tys
| Class
cls Class -> ClassSet -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` ClassSet
so_far
= (Bool, SDoc) -> Maybe (Bool, SDoc)
forall a. a -> Maybe a
Just (Bool
True, String -> SDoc
text String
"one of whose superclasses is" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls))
| Class -> Bool
isCTupleClass Class
cls
= ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go ClassSet
so_far Class
cls [Type]
tys
| Bool
otherwise
= do { (Bool
b,SDoc
err) <- ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go (ClassSet
so_far ClassSet -> Class -> ClassSet
forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`addOneToUniqSet` Class
cls) Class
cls [Type]
tys
; (Bool, SDoc) -> Maybe (Bool, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, String -> SDoc
text String
"one of whose superclasses is" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
cls)
SDoc -> SDoc -> SDoc
$$ SDoc
err) }
type RolesInfo = Name -> [Role]
type RoleEnv = NameEnv [Role]
inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
inferRoles HscSource
hsc_src RoleAnnotEnv
annots [TyCon]
tycons
= let role_env :: RoleEnv
role_env = HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
initialRoleEnv HscSource
hsc_src RoleAnnotEnv
annots [TyCon]
tycons
role_env' :: RoleEnv
role_env' = RoleEnv -> [TyCon] -> RoleEnv
irGroup RoleEnv
role_env [TyCon]
tycons in
\Name
name -> case RoleEnv -> Name -> Maybe [Role]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env' Name
name of
Just [Role]
roles -> [Role]
roles
Maybe [Role]
Nothing -> String -> SDoc -> [Role]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"inferRoles" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
initialRoleEnv HscSource
hsc_src RoleAnnotEnv
annots = RoleEnv -> [(Name, [Role])] -> RoleEnv
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList RoleEnv
forall a. NameEnv a
emptyNameEnv ([(Name, [Role])] -> RoleEnv)
-> ([TyCon] -> [(Name, [Role])]) -> [TyCon] -> RoleEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(TyCon -> (Name, [Role])) -> [TyCon] -> [(Name, [Role])]
forall a b. (a -> b) -> [a] -> [b]
map (HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
initialRoleEnv1 HscSource
hsc_src RoleAnnotEnv
annots)
initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
initialRoleEnv1 HscSource
hsc_src RoleAnnotEnv
annots_env TyCon
tc
| TyCon -> Bool
isFamilyTyCon TyCon
tc = (Name
name, (TyConBinder -> Role) -> [TyConBinder] -> [Role]
forall a b. (a -> b) -> [a] -> [b]
map (Role -> TyConBinder -> Role
forall a b. a -> b -> a
const Role
Nominal) [TyConBinder]
bndrs)
| TyCon -> Bool
isAlgTyCon TyCon
tc = (Name
name, [Role]
default_roles)
| TyCon -> Bool
isTypeSynonymTyCon TyCon
tc = (Name
name, [Role]
default_roles)
| Bool
otherwise = String -> SDoc -> (Name, [Role])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initialRoleEnv1" (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc)
where name :: Name
name = TyCon -> Name
tyConName TyCon
tc
bndrs :: [TyConBinder]
bndrs = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
argflags :: [ArgFlag]
argflags = (TyConBinder -> ArgFlag) -> [TyConBinder] -> [ArgFlag]
forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> ArgFlag
tyConBinderArgFlag [TyConBinder]
bndrs
num_exps :: BranchIndex
num_exps = (ArgFlag -> Bool) -> [ArgFlag] -> BranchIndex
forall a. (a -> Bool) -> [a] -> BranchIndex
count ArgFlag -> Bool
isVisibleArgFlag [ArgFlag]
argflags
role_annots :: [Maybe Role]
role_annots
= case RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn)
lookupRoleAnnot RoleAnnotEnv
annots_env Name
name of
Just (L _ (RoleAnnotDecl _ _ annots))
| [XRec GhcRn (Maybe Role)]
[GenLocated (SrcAnn NoEpAnns) (Maybe Role)]
annots [GenLocated (SrcAnn NoEpAnns) (Maybe Role)] -> BranchIndex -> Bool
forall a. [a] -> BranchIndex -> Bool
`lengthIs` BranchIndex
num_exps -> (GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> Maybe Role)
-> [GenLocated (SrcAnn NoEpAnns) (Maybe Role)] -> [Maybe Role]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated (SrcAnn NoEpAnns) (Maybe Role) -> Maybe Role
forall l e. GenLocated l e -> e
unLoc [XRec GhcRn (Maybe Role)]
[GenLocated (SrcAnn NoEpAnns) (Maybe Role)]
annots
Maybe (LRoleAnnotDecl GhcRn)
_ -> BranchIndex -> Maybe Role -> [Maybe Role]
forall a. BranchIndex -> a -> [a]
replicate BranchIndex
num_exps Maybe Role
forall a. Maybe a
Nothing
default_roles :: [Role]
default_roles = [ArgFlag] -> [Maybe Role] -> [Role]
build_default_roles [ArgFlag]
argflags [Maybe Role]
role_annots
build_default_roles :: [ArgFlag] -> [Maybe Role] -> [Role]
build_default_roles (ArgFlag
argf : [ArgFlag]
argfs) (Maybe Role
m_annot : [Maybe Role]
ras)
| ArgFlag -> Bool
isVisibleArgFlag ArgFlag
argf
= (Maybe Role
m_annot Maybe Role -> Role -> Role
forall a. Maybe a -> a -> a
`orElse` Role
default_role) Role -> [Role] -> [Role]
forall a. a -> [a] -> [a]
: [ArgFlag] -> [Maybe Role] -> [Role]
build_default_roles [ArgFlag]
argfs [Maybe Role]
ras
build_default_roles (ArgFlag
_argf : [ArgFlag]
argfs) [Maybe Role]
ras
= Role
Nominal Role -> [Role] -> [Role]
forall a. a -> [a] -> [a]
: [ArgFlag] -> [Maybe Role] -> [Role]
build_default_roles [ArgFlag]
argfs [Maybe Role]
ras
build_default_roles [] [] = []
build_default_roles [ArgFlag]
_ [Maybe Role]
_ = String -> SDoc -> [Role]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initialRoleEnv1 (2)"
([SDoc] -> SDoc
vcat [TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc, [Maybe Role] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Maybe Role]
role_annots])
default_role :: Role
default_role
| TyCon -> Bool
isClassTyCon TyCon
tc = Role
Nominal
| HscSource
HsBootFile <- HscSource
hsc_src
, TyCon -> Bool
isAbstractTyCon TyCon
tc = Role
Representational
| HscSource
HsigFile <- HscSource
hsc_src
, TyCon -> Bool
isAbstractTyCon TyCon
tc = Role
Nominal
| Bool
otherwise = Role
Phantom
irGroup :: RoleEnv -> [TyCon] -> RoleEnv
irGroup :: RoleEnv -> [TyCon] -> RoleEnv
irGroup RoleEnv
env [TyCon]
tcs
= let (RoleEnv
env', Bool
update) = RoleEnv -> RoleM () -> (RoleEnv, Bool)
runRoleM RoleEnv
env (RoleM () -> (RoleEnv, Bool)) -> RoleM () -> (RoleEnv, Bool)
forall a b. (a -> b) -> a -> b
$ (TyCon -> RoleM ()) -> [TyCon] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TyCon -> RoleM ()
irTyCon [TyCon]
tcs in
if Bool
update
then RoleEnv -> [TyCon] -> RoleEnv
irGroup RoleEnv
env' [TyCon]
tcs
else RoleEnv
env'
irTyCon :: TyCon -> RoleM ()
irTyCon :: TyCon -> RoleM ()
irTyCon TyCon
tc
| TyCon -> Bool
isAlgTyCon TyCon
tc
= do { [Role]
old_roles <- TyCon -> RoleM [Role]
lookupRoles TyCon
tc
; Bool -> RoleM () -> RoleM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Role -> Bool) -> [Role] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Role -> Role -> Bool
forall a. Eq a => a -> a -> Bool
== Role
Nominal) [Role]
old_roles) (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
TyCon -> RoleM () -> RoleM ()
forall a. TyCon -> RoleM a -> RoleM a
irTcTyVars TyCon
tc (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
do { (Type -> RoleM ()) -> [Type] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> Type -> RoleM ()
irType VarSet
emptyVarSet) (TyCon -> [Type]
tyConStupidTheta TyCon
tc)
; Maybe Class -> (Class -> RoleM ()) -> RoleM ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc) Class -> RoleM ()
irClass
; (DataCon -> RoleM ()) -> [DataCon] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DataCon -> RoleM ()
irDataCon (AlgTyConRhs -> [DataCon]
visibleDataCons (AlgTyConRhs -> [DataCon]) -> AlgTyConRhs -> [DataCon]
forall a b. (a -> b) -> a -> b
$ TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc) }}
| Just Type
ty <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc
= TyCon -> RoleM () -> RoleM ()
forall a. TyCon -> RoleM a -> RoleM a
irTcTyVars TyCon
tc (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
VarSet -> Type -> RoleM ()
irType VarSet
emptyVarSet Type
ty
| Bool
otherwise
= () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
irClass :: Class -> RoleM ()
irClass :: Class -> RoleM ()
irClass Class
cls
= (TyCon -> RoleM ()) -> [TyCon] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TyCon -> RoleM ()
ir_at (Class -> [TyCon]
classATs Class
cls)
where
cls_tvs :: [Var]
cls_tvs = Class -> [Var]
classTyVars Class
cls
cls_tv_set :: VarSet
cls_tv_set = [Var] -> VarSet
mkVarSet [Var]
cls_tvs
ir_at :: TyCon -> RoleM ()
ir_at TyCon
at_tc
= (Var -> RoleM ()) -> [Var] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Role -> Var -> RoleM ()
updateRole Role
Nominal) [Var]
nvars
where nvars :: [Var]
nvars = (Var -> Bool) -> [Var] -> [Var]
forall a. (a -> Bool) -> [a] -> [a]
filter (Var -> VarSet -> Bool
`elemVarSet` VarSet
cls_tv_set) ([Var] -> [Var]) -> [Var] -> [Var]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Var]
tyConTyVars TyCon
at_tc
irDataCon :: DataCon -> RoleM ()
irDataCon :: DataCon -> RoleM ()
irDataCon DataCon
datacon
= [Var] -> RoleM () -> RoleM ()
forall a. [Var] -> RoleM a -> RoleM a
setRoleInferenceVars [Var]
univ_tvs (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
[Var] -> (VarSet -> RoleM ()) -> RoleM ()
forall a. [Var] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [Var]
ex_tvs ((VarSet -> RoleM ()) -> RoleM ())
-> (VarSet -> RoleM ()) -> RoleM ()
forall a b. (a -> b) -> a -> b
$ \ VarSet
ex_var_set ->
do (Type -> RoleM ()) -> [Type] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> Type -> RoleM ()
irType VarSet
ex_var_set) ([EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
(Type -> RoleM ()) -> [Type] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> Type -> RoleM ()
markNominal VarSet
ex_var_set) ((Var -> Type) -> [Var] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Type
tyVarKind [Var]
ex_tvs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ (Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> Type
scaledMult [Scaled Type]
arg_tys)
where
([Var]
univ_tvs, [Var]
ex_tvs, [EqSpec]
eq_spec, [Type]
theta, [Scaled Type]
arg_tys, Type
_res_ty)
= DataCon -> ([Var], [Var], [EqSpec], [Type], [Scaled Type], Type)
dataConFullSig DataCon
datacon
irType :: VarSet -> Type -> RoleM ()
irType :: VarSet -> Type -> RoleM ()
irType = VarSet -> Type -> RoleM ()
go
where
go :: VarSet -> Type -> RoleM ()
go VarSet
lcls Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty
= VarSet -> Type -> RoleM ()
go VarSet
lcls Type
ty'
go VarSet
lcls (TyVarTy Var
tv) = Bool -> RoleM () -> RoleM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Var
tv Var -> VarSet -> Bool
`elemVarSet` VarSet
lcls) (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
Role -> Var -> RoleM ()
updateRole Role
Representational Var
tv
go VarSet
lcls (AppTy Type
t1 Type
t2) = VarSet -> Type -> RoleM ()
go VarSet
lcls Type
t1 RoleM () -> RoleM () -> RoleM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> Type -> RoleM ()
markNominal VarSet
lcls Type
t2
go VarSet
lcls (TyConApp TyCon
tc [Type]
tys) = do { [Role]
roles <- TyCon -> RoleM [Role]
lookupRolesX TyCon
tc
; (Role -> Type -> RoleM ()) -> [Role] -> [Type] -> RoleM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (VarSet -> Role -> Type -> RoleM ()
go_app VarSet
lcls) [Role]
roles [Type]
tys }
go VarSet
lcls (ForAllTy TyCoVarBinder
tvb Type
ty) = do { let tv :: Var
tv = TyCoVarBinder -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
tvb
lcls' :: VarSet
lcls' = VarSet -> Var -> VarSet
extendVarSet VarSet
lcls Var
tv
; VarSet -> Type -> RoleM ()
markNominal VarSet
lcls (Var -> Type
tyVarKind Var
tv)
; VarSet -> Type -> RoleM ()
go VarSet
lcls' Type
ty }
go VarSet
lcls (FunTy AnonArgFlag
_ Type
w Type
arg Type
res) = VarSet -> Type -> RoleM ()
markNominal VarSet
lcls Type
w RoleM () -> RoleM () -> RoleM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> Type -> RoleM ()
go VarSet
lcls Type
arg RoleM () -> RoleM () -> RoleM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> Type -> RoleM ()
go VarSet
lcls Type
res
go VarSet
_ (LitTy {}) = () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go VarSet
lcls (CastTy Type
ty KindCoercion
_) = VarSet -> Type -> RoleM ()
go VarSet
lcls Type
ty
go VarSet
_ (CoercionTy KindCoercion
_) = () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_app :: VarSet -> Role -> Type -> RoleM ()
go_app VarSet
_ Role
Phantom Type
_ = () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_app VarSet
lcls Role
Nominal Type
ty = VarSet -> Type -> RoleM ()
markNominal VarSet
lcls Type
ty
go_app VarSet
lcls Role
Representational Type
ty = VarSet -> Type -> RoleM ()
go VarSet
lcls Type
ty
irTcTyVars :: TyCon -> RoleM a -> RoleM a
irTcTyVars :: TyCon -> RoleM a -> RoleM a
irTcTyVars TyCon
tc RoleM a
thing
= Name -> RoleM a -> RoleM a
forall a. Name -> RoleM a -> RoleM a
setRoleInferenceTc (TyCon -> Name
tyConName TyCon
tc) (RoleM a -> RoleM a) -> RoleM a -> RoleM a
forall a b. (a -> b) -> a -> b
$ [Var] -> RoleM a
go (TyCon -> [Var]
tyConTyVars TyCon
tc)
where
go :: [Var] -> RoleM a
go [] = RoleM a
thing
go (Var
tv:[Var]
tvs) = do { VarSet -> Type -> RoleM ()
markNominal VarSet
emptyVarSet (Var -> Type
tyVarKind Var
tv)
; Var -> RoleM a -> RoleM a
forall a. Var -> RoleM a -> RoleM a
addRoleInferenceVar Var
tv (RoleM a -> RoleM a) -> RoleM a -> RoleM a
forall a b. (a -> b) -> a -> b
$ [Var] -> RoleM a
go [Var]
tvs }
irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a
irExTyVars :: [Var] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [Var]
orig_tvs VarSet -> RoleM a
thing = VarSet -> [Var] -> RoleM a
go VarSet
emptyVarSet [Var]
orig_tvs
where
go :: VarSet -> [Var] -> RoleM a
go VarSet
lcls [] = VarSet -> RoleM a
thing VarSet
lcls
go VarSet
lcls (Var
tv:[Var]
tvs) = do { VarSet -> Type -> RoleM ()
markNominal VarSet
lcls (Var -> Type
tyVarKind Var
tv)
; VarSet -> [Var] -> RoleM a
go (VarSet -> Var -> VarSet
extendVarSet VarSet
lcls Var
tv) [Var]
tvs }
markNominal :: TyVarSet
-> Type -> RoleM ()
markNominal :: VarSet -> Type -> RoleM ()
markNominal VarSet
lcls Type
ty = let nvars :: [Var]
nvars = FV -> [Var]
fvVarList (VarSet -> FV -> FV
FV.delFVs VarSet
lcls (FV -> FV) -> FV -> FV
forall a b. (a -> b) -> a -> b
$ Type -> FV
get_ty_vars Type
ty) in
(Var -> RoleM ()) -> [Var] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Role -> Var -> RoleM ()
updateRole Role
Nominal) [Var]
nvars
where
get_ty_vars :: Type -> FV
get_ty_vars :: Type -> FV
get_ty_vars Type
t | Just Type
t' <- Type -> Maybe Type
coreView Type
t
= Type -> FV
get_ty_vars Type
t'
get_ty_vars (TyVarTy Var
tv) = Var -> FV
unitFV Var
tv
get_ty_vars (AppTy Type
t1 Type
t2) = Type -> FV
get_ty_vars Type
t1 FV -> FV -> FV
`unionFV` Type -> FV
get_ty_vars Type
t2
get_ty_vars (FunTy AnonArgFlag
_ Type
w Type
t1 Type
t2) = Type -> FV
get_ty_vars Type
w FV -> FV -> FV
`unionFV` Type -> FV
get_ty_vars Type
t1 FV -> FV -> FV
`unionFV` Type -> FV
get_ty_vars Type
t2
get_ty_vars (TyConApp TyCon
_ [Type]
tys) = (Type -> FV) -> [Type] -> FV
forall a. (a -> FV) -> [a] -> FV
mapUnionFV Type -> FV
get_ty_vars [Type]
tys
get_ty_vars (ForAllTy TyCoVarBinder
tvb Type
ty) = TyCoVarBinder -> FV -> FV
tyCoFVsBndr TyCoVarBinder
tvb (Type -> FV
get_ty_vars Type
ty)
get_ty_vars (LitTy {}) = FV
emptyFV
get_ty_vars (CastTy Type
ty KindCoercion
_) = Type -> FV
get_ty_vars Type
ty
get_ty_vars (CoercionTy KindCoercion
_) = FV
emptyFV
lookupRolesX :: TyCon -> RoleM [Role]
lookupRolesX :: TyCon -> RoleM [Role]
lookupRolesX TyCon
tc
= do { [Role]
roles <- TyCon -> RoleM [Role]
lookupRoles TyCon
tc
; [Role] -> RoleM [Role]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Role] -> RoleM [Role]) -> [Role] -> RoleM [Role]
forall a b. (a -> b) -> a -> b
$ [Role]
roles [Role] -> [Role] -> [Role]
forall a. [a] -> [a] -> [a]
++ Role -> [Role]
forall a. a -> [a]
repeat Role
Nominal }
lookupRoles :: TyCon -> RoleM [Role]
lookupRoles :: TyCon -> RoleM [Role]
lookupRoles TyCon
tc
= do { RoleEnv
env <- RoleM RoleEnv
getRoleEnv
; case RoleEnv -> Name -> Maybe [Role]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
env (TyCon -> Name
tyConName TyCon
tc) of
Just [Role]
roles -> [Role] -> RoleM [Role]
forall (m :: * -> *) a. Monad m => a -> m a
return [Role]
roles
Maybe [Role]
Nothing -> [Role] -> RoleM [Role]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Role] -> RoleM [Role]) -> [Role] -> RoleM [Role]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Role]
tyConRoles TyCon
tc }
updateRole :: Role -> TyVar -> RoleM ()
updateRole :: Role -> Var -> RoleM ()
updateRole Role
role Var
tv
= do { VarPositions
var_ns <- RoleM VarPositions
getVarNs
; Name
name <- RoleM Name
getTyConName
; case VarPositions -> Var -> Maybe BranchIndex
forall a. VarEnv a -> Var -> Maybe a
lookupVarEnv VarPositions
var_ns Var
tv of
Maybe BranchIndex
Nothing -> String -> SDoc -> RoleM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"updateRole" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
tv SDoc -> SDoc -> SDoc
$$ VarPositions -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarPositions
var_ns)
Just BranchIndex
n -> Name -> BranchIndex -> Role -> RoleM ()
updateRoleEnv Name
name BranchIndex
n Role
role }
data RoleInferenceState = RIS { RoleInferenceState -> RoleEnv
role_env :: RoleEnv
, RoleInferenceState -> Bool
update :: Bool }
type VarPositions = VarEnv Int
newtype RoleM a = RM { RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM :: Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState) }
deriving (a -> RoleM b -> RoleM a
(a -> b) -> RoleM a -> RoleM b
(forall a b. (a -> b) -> RoleM a -> RoleM b)
-> (forall a b. a -> RoleM b -> RoleM a) -> Functor RoleM
forall a b. a -> RoleM b -> RoleM a
forall a b. (a -> b) -> RoleM a -> RoleM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RoleM b -> RoleM a
$c<$ :: forall a b. a -> RoleM b -> RoleM a
fmap :: (a -> b) -> RoleM a -> RoleM b
$cfmap :: forall a b. (a -> b) -> RoleM a -> RoleM b
Functor)
instance Applicative RoleM where
pure :: a -> RoleM a
pure a
x = (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
_ BranchIndex
_ RoleInferenceState
state -> (a
x, RoleInferenceState
state)
<*> :: RoleM (a -> b) -> RoleM a -> RoleM b
(<*>) = RoleM (a -> b) -> RoleM a -> RoleM b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad RoleM where
RoleM a
a >>= :: RoleM a -> (a -> RoleM b) -> RoleM b
>>= a -> RoleM b
f = (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (b, RoleInferenceState))
-> RoleM b
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (b, RoleInferenceState))
-> RoleM b)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (b, RoleInferenceState))
-> RoleM b
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_info VarPositions
vps BranchIndex
nvps RoleInferenceState
state ->
let (a
a', RoleInferenceState
state') = RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
a Maybe Name
m_info VarPositions
vps BranchIndex
nvps RoleInferenceState
state in
RoleM b
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (b, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM (a -> RoleM b
f a
a') Maybe Name
m_info VarPositions
vps BranchIndex
nvps RoleInferenceState
state'
runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
runRoleM RoleEnv
env RoleM ()
thing = (RoleEnv
env', Bool
update)
where RIS { role_env :: RoleInferenceState -> RoleEnv
role_env = RoleEnv
env', update :: RoleInferenceState -> Bool
update = Bool
update }
= ((), RoleInferenceState) -> RoleInferenceState
forall a b. (a, b) -> b
snd (((), RoleInferenceState) -> RoleInferenceState)
-> ((), RoleInferenceState) -> RoleInferenceState
forall a b. (a -> b) -> a -> b
$ RoleM ()
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> ((), RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM ()
thing Maybe Name
forall a. Maybe a
Nothing VarPositions
forall a. VarEnv a
emptyVarEnv BranchIndex
0 RoleInferenceState
state
state :: RoleInferenceState
state = RIS :: RoleEnv -> Bool -> RoleInferenceState
RIS { role_env :: RoleEnv
role_env = RoleEnv
env
, update :: Bool
update = Bool
False }
setRoleInferenceTc :: Name -> RoleM a -> RoleM a
setRoleInferenceTc :: Name -> RoleM a -> RoleM a
setRoleInferenceTc Name
name RoleM a
thing = (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
vps BranchIndex
nvps RoleInferenceState
state ->
Bool -> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Name -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Name
m_name) ((a, RoleInferenceState) -> (a, RoleInferenceState))
-> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a b. (a -> b) -> a -> b
$
Bool -> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a. HasCallStack => Bool -> a -> a
assert (VarPositions -> Bool
forall a. VarEnv a -> Bool
isEmptyVarEnv VarPositions
vps) ((a, RoleInferenceState) -> (a, RoleInferenceState))
-> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a b. (a -> b) -> a -> b
$
Bool -> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a. HasCallStack => Bool -> a -> a
assert (BranchIndex
nvps BranchIndex -> BranchIndex -> Bool
forall a. Eq a => a -> a -> Bool
== BranchIndex
0) ((a, RoleInferenceState) -> (a, RoleInferenceState))
-> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a b. (a -> b) -> a -> b
$
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) VarPositions
vps BranchIndex
nvps RoleInferenceState
state
addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
addRoleInferenceVar :: Var -> RoleM a -> RoleM a
addRoleInferenceVar Var
tv RoleM a
thing
= (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
vps BranchIndex
nvps RoleInferenceState
state ->
Bool -> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
m_name) ((a, RoleInferenceState) -> (a, RoleInferenceState))
-> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a b. (a -> b) -> a -> b
$
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name (VarPositions -> Var -> BranchIndex -> VarPositions
forall a. VarEnv a -> Var -> a -> VarEnv a
extendVarEnv VarPositions
vps Var
tv BranchIndex
nvps) (BranchIndex
nvpsBranchIndex -> BranchIndex -> BranchIndex
forall a. Num a => a -> a -> a
+BranchIndex
1) RoleInferenceState
state
setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
setRoleInferenceVars :: [Var] -> RoleM a -> RoleM a
setRoleInferenceVars [Var]
tvs RoleM a
thing
= (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_vps BranchIndex
_nvps RoleInferenceState
state ->
Bool -> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe Name -> Bool
forall a. Maybe a -> Bool
isJust Maybe Name
m_name) ((a, RoleInferenceState) -> (a, RoleInferenceState))
-> (a, RoleInferenceState) -> (a, RoleInferenceState)
forall a b. (a -> b) -> a -> b
$
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name ([(Var, BranchIndex)] -> VarPositions
forall a. [(Var, a)] -> VarEnv a
mkVarEnv ([Var] -> [BranchIndex] -> [(Var, BranchIndex)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
tvs [BranchIndex
0..])) (String -> BranchIndex
forall a. String -> a
panic String
"setRoleInferenceVars")
RoleInferenceState
state
getRoleEnv :: RoleM RoleEnv
getRoleEnv :: RoleM RoleEnv
getRoleEnv = (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (RoleEnv, RoleInferenceState))
-> RoleM RoleEnv
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (RoleEnv, RoleInferenceState))
-> RoleM RoleEnv)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (RoleEnv, RoleInferenceState))
-> RoleM RoleEnv
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
_ BranchIndex
_ state :: RoleInferenceState
state@(RIS { role_env :: RoleInferenceState -> RoleEnv
role_env = RoleEnv
env }) -> (RoleEnv
env, RoleInferenceState
state)
getVarNs :: RoleM VarPositions
getVarNs :: RoleM VarPositions
getVarNs = (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (VarPositions, RoleInferenceState))
-> RoleM VarPositions
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (VarPositions, RoleInferenceState))
-> RoleM VarPositions)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (VarPositions, RoleInferenceState))
-> RoleM VarPositions
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
vps BranchIndex
_ RoleInferenceState
state -> (VarPositions
vps, RoleInferenceState
state)
getTyConName :: RoleM Name
getTyConName :: RoleM Name
getTyConName = (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (Name, RoleInferenceState))
-> RoleM Name
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (Name, RoleInferenceState))
-> RoleM Name)
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (Name, RoleInferenceState))
-> RoleM Name
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_ BranchIndex
_ RoleInferenceState
state ->
case Maybe Name
m_name of
Maybe Name
Nothing -> String -> (Name, RoleInferenceState)
forall a. String -> a
panic String
"getTyConName"
Just Name
name -> (Name
name, RoleInferenceState
state)
updateRoleEnv :: Name -> Int -> Role -> RoleM ()
updateRoleEnv :: Name -> BranchIndex -> Role -> RoleM ()
updateRoleEnv Name
name BranchIndex
n Role
role
= (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> ((), RoleInferenceState))
-> RoleM ()
forall a.
(Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> ((), RoleInferenceState))
-> RoleM ())
-> (Maybe Name
-> VarPositions
-> BranchIndex
-> RoleInferenceState
-> ((), RoleInferenceState))
-> RoleM ()
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
_ BranchIndex
_ state :: RoleInferenceState
state@(RIS { role_env :: RoleInferenceState -> RoleEnv
role_env = RoleEnv
role_env }) -> ((),
case RoleEnv -> Name -> Maybe [Role]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env Name
name of
Maybe [Role]
Nothing -> String -> SDoc -> RoleInferenceState
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"updateRoleEnv" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
Just [Role]
roles -> let ([Role]
before, Role
old_role : [Role]
after) = BranchIndex -> [Role] -> ([Role], [Role])
forall a. BranchIndex -> [a] -> ([a], [a])
splitAt BranchIndex
n [Role]
roles in
if Role
role Role -> Role -> Bool
`ltRole` Role
old_role
then let roles' :: [Role]
roles' = [Role]
before [Role] -> [Role] -> [Role]
forall a. [a] -> [a] -> [a]
++ Role
role Role -> [Role] -> [Role]
forall a. a -> [a] -> [a]
: [Role]
after
role_env' :: RoleEnv
role_env' = RoleEnv -> Name -> [Role] -> RoleEnv
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv RoleEnv
role_env Name
name [Role]
roles' in
RIS :: RoleEnv -> Bool -> RoleInferenceState
RIS { role_env :: RoleEnv
role_env = RoleEnv
role_env', update :: Bool
update = Bool
True }
else RoleInferenceState
state )
addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv)
addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv)
addTyConsToGblEnv [TyCon]
tyclss
= [TyCon] -> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tyclss (TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv))
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a b. (a -> b) -> a -> b
$
[TyThing] -> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
implicit_things (TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv))
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a b. (a -> b) -> a -> b
$
[Var] -> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var]
def_meth_ids (TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv))
-> TcM (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tcAddTyCons" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tycons" SDoc -> SDoc -> SDoc
<+> [TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss
, String -> SDoc
text String
"implicits" SDoc -> SDoc -> SDoc
<+> [TyThing] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyThing]
implicit_things ]
; TcGblEnv
gbl_env <- [(Var, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds ([TyCon] -> [(Var, LHsBind GhcRn)]
mkRecSelBinds [TyCon]
tyclss)
; ThBindEnv
th_bndrs <- [TyThing] -> TcM ThBindEnv
tcTyThBinders [TyThing]
implicit_things
; (TcGblEnv, ThBindEnv) -> TcM (TcGblEnv, ThBindEnv)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
gbl_env, ThBindEnv
th_bndrs)
}
where
implicit_things :: [TyThing]
implicit_things = (TyCon -> [TyThing]) -> [TyCon] -> [TyThing]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyCon -> [TyThing]
implicitTyConThings [TyCon]
tyclss
def_meth_ids :: [Var]
def_meth_ids = [TyCon] -> [Var]
mkDefaultMethodIds [TyCon]
tyclss
mkDefaultMethodIds :: [TyCon] -> [Id]
mkDefaultMethodIds :: [TyCon] -> [Var]
mkDefaultMethodIds [TyCon]
tycons
= [ Name -> Type -> Var
mkExportedVanillaId Name
dm_name (Class -> Var -> DefMethSpec Type -> Type
mkDefaultMethodType Class
cls Var
sel_id DefMethSpec Type
dm_spec)
| TyCon
tc <- [TyCon]
tycons
, Just Class
cls <- [TyCon -> Maybe Class
tyConClass_maybe TyCon
tc]
, (Var
sel_id, Just (Name
dm_name, DefMethSpec Type
dm_spec)) <- Class -> [(Var, DefMethInfo)]
classOpItems Class
cls ]
mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
mkDefaultMethodType :: Class -> Var -> DefMethSpec Type -> Type
mkDefaultMethodType Class
_ Var
sel_id DefMethSpec Type
VanillaDM = Var -> Type
idType Var
sel_id
mkDefaultMethodType Class
cls Var
_ (GenericDM Type
dm_ty) = [TyCoVarBinder] -> [Type] -> Type -> Type
mkSigmaTy [TyCoVarBinder]
tv_bndrs [Type
pred] Type
dm_ty
where
pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
cls ([Var] -> [Type]
mkTyVarTys ([TyConBinder] -> [Var]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyConBinder]
cls_bndrs))
cls_bndrs :: [TyConBinder]
cls_bndrs = TyCon -> [TyConBinder]
tyConBinders (Class -> TyCon
classTyCon Class
cls)
tv_bndrs :: [TyCoVarBinder]
tv_bndrs = [VarBndr Var Specificity] -> [TyCoVarBinder]
forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders ([VarBndr Var Specificity] -> [TyCoVarBinder])
-> [VarBndr Var Specificity] -> [TyCoVarBinder]
forall a b. (a -> b) -> a -> b
$ [TyConBinder] -> [VarBndr Var Specificity]
tyConInvisTVBinders [TyConBinder]
cls_bndrs
tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds :: [(Var, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds [(Var, LHsBind GhcRn)]
sel_bind_prs
= [Var] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Var] -> TcM a -> TcM a
tcExtendGlobalValEnv [Var
sel_id | (L SrcSpanAnn' (EpAnn AnnListItem)
_ (IdSig XIdSig GhcRn
_ Var
sel_id)) <- [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Sig GhcRn)]
sigs] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { ([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))]
rec_sel_binds, TcGblEnv
tcg_env) <- TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
forall a. TcRn a -> TcRn a
discardWarnings (TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv))
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ImpredicativeTypes (TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv))
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
-> TcRn
([(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))],
TcGblEnv)
forall a b. (a -> b) -> a -> b
$
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM TcGblEnv
-> TcM ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag, LHsBinds GhcRn)]
[(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)))]
binds [LSig GhcRn]
[GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Sig GhcRn)]
sigs TcM TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` ((RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))
-> Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))
-> [(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))]
-> [Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))
-> Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc))
forall a b. (a, b) -> b
snd [(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcTc GhcTc)))]
rec_sel_binds) }
where
sigs :: [GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Sig GhcRn)]
sigs = [ SrcSpanAnn' (EpAnn AnnListItem)
-> Sig GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XIdSig GhcRn -> Var -> Sig GhcRn
forall pass. XIdSig pass -> Var -> Sig pass
IdSig NoExtField
XIdSig GhcRn
noExtField Var
sel_id)
| (Var
sel_id, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)
_) <- [(Var, LHsBind GhcRn)]
[(Var,
GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn))]
sel_bind_prs
, let loc :: SrcSpan
loc = Var -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Var
sel_id ]
binds :: [(RecFlag,
Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)))]
binds = [(RecFlag
NonRecursive, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)
-> Bag
(GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn))
forall a. a -> Bag a
unitBag GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)
bind) | (Var
_, GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)
bind) <- [(Var, LHsBind GhcRn)]
[(Var,
GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn))]
sel_bind_prs]
mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
mkRecSelBinds :: [TyCon] -> [(Var, LHsBind GhcRn)]
mkRecSelBinds [TyCon]
tycons
= ((TyCon, FieldLabel)
-> (Var,
GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)))
-> [(TyCon, FieldLabel)]
-> [(Var,
GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn))]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon, FieldLabel) -> (Var, LHsBind GhcRn)
(TyCon, FieldLabel)
-> (Var,
GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn))
mkRecSelBind [ (TyCon
tc,FieldLabel
fld) | TyCon
tc <- [TyCon]
tycons
, FieldLabel
fld <- TyCon -> [FieldLabel]
tyConFieldLabels TyCon
tc ]
mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
mkRecSelBind :: (TyCon, FieldLabel) -> (Var, LHsBind GhcRn)
mkRecSelBind (TyCon
tycon, FieldLabel
fl)
= [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (Var, LHsBind GhcRn)
mkOneRecordSelector [ConLike]
all_cons (TyCon -> RecSelParent
RecSelData TyCon
tycon) FieldLabel
fl
FieldSelectors
FieldSelectors
where
all_cons :: [ConLike]
all_cons = (DataCon -> ConLike) -> [DataCon] -> [ConLike]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)
mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
-> (Id, LHsBind GhcRn)
mkOneRecordSelector :: [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (Var, LHsBind GhcRn)
mkOneRecordSelector [ConLike]
all_cons RecSelParent
idDetails FieldLabel
fl FieldSelectors
has_sel
= (Var
sel_id, SrcSpanAnn' (EpAnn AnnListItem)
-> HsBindLR GhcRn GhcRn
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem)) (HsBindLR GhcRn GhcRn)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) HsBindLR GhcRn GhcRn
sel_bind)
where
loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
sel_name
loc' :: SrcSpanAnn' (EpAnn AnnListItem)
loc' = SrcSpan -> SrcSpanAnn' (EpAnn AnnListItem)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
locn :: SrcAnn NameAnn
locn = SrcSpan -> SrcAnn NameAnn
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
locc :: SrcAnn NoEpAnns
locc = SrcSpan -> SrcAnn NoEpAnns
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
lbl :: FieldLabelString
lbl = FieldLabel -> FieldLabelString
flLabel FieldLabel
fl
sel_name :: Name
sel_name = FieldLabel -> Name
flSelector FieldLabel
fl
sel_id :: Var
sel_id = IdDetails -> Name -> Type -> Var
mkExportedLocalId IdDetails
rec_details Name
sel_name Type
sel_ty
rec_details :: IdDetails
rec_details = RecSelId :: RecSelParent -> Bool -> IdDetails
RecSelId { sel_tycon :: RecSelParent
sel_tycon = RecSelParent
idDetails, sel_naughty :: Bool
sel_naughty = Bool
is_naughty }
cons_w_field :: [ConLike]
cons_w_field = [ConLike] -> [FieldLabelString] -> [ConLike]
conLikesWithFields [ConLike]
all_cons [FieldLabelString
lbl]
con1 :: ConLike
con1 = Bool -> ConLike -> ConLike
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not ([ConLike] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConLike]
cons_w_field)) (ConLike -> ConLike) -> ConLike -> ConLike
forall a b. (a -> b) -> a -> b
$ [ConLike] -> ConLike
forall a. [a] -> a
head [ConLike]
cons_w_field
field_ty :: Type
field_ty = ConLike -> FieldLabelString -> Type
conLikeFieldType ConLike
con1 FieldLabelString
lbl
data_tvbs :: [VarBndr Var Specificity]
data_tvbs = (VarBndr Var Specificity -> Bool)
-> [VarBndr Var Specificity] -> [VarBndr Var Specificity]
forall a. (a -> Bool) -> [a] -> [a]
filter (\VarBndr Var Specificity
tvb -> VarBndr Var Specificity -> Var
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr Var Specificity
tvb Var -> VarSet -> Bool
`elemVarSet` VarSet
data_tv_set) ([VarBndr Var Specificity] -> [VarBndr Var Specificity])
-> [VarBndr Var Specificity] -> [VarBndr Var Specificity]
forall a b. (a -> b) -> a -> b
$
ConLike -> [VarBndr Var Specificity]
conLikeUserTyVarBinders ConLike
con1
data_tv_set :: VarSet
data_tv_set= [Type] -> VarSet
tyCoVarsOfTypes [Type]
inst_tys
is_naughty :: Bool
is_naughty = Bool -> Bool
not (Type -> VarSet
tyCoVarsOfType Type
field_ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
data_tv_set)
Bool -> Bool -> Bool
|| FieldSelectors
has_sel FieldSelectors -> FieldSelectors -> Bool
forall a. Eq a => a -> a -> Bool
== FieldSelectors
NoFieldSelectors
sel_ty :: Type
sel_ty | Bool
is_naughty = Type
unitTy
| Bool
otherwise = [TyCoVarBinder] -> Type -> Type
mkForAllTys ([VarBndr Var Specificity] -> [TyCoVarBinder]
forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders [VarBndr Var Specificity]
data_tvbs) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy (ConLike -> [Type]
conLikeStupidTheta ConLike
con1) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
[Type] -> Type -> Type
mkPhiTy [Type]
req_theta (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type -> Type -> Type
mkVisFunTyMany Type
data_ty (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
field_ty
sel_bind :: HsBindLR GhcRn GhcRn
sel_bind = Origin
-> LocatedN Name
-> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBindLR GhcRn GhcRn
mkTopFunBind Origin
Generated LocatedN Name
sel_lname [LMatch GhcRn (LHsExpr GhcRn)]
[GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
alts
where
alts :: [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
alts | Bool
is_naughty = [HsMatchContext GhcRn
-> [LPat GhcRn]
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
-> LMatch
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnn' (EpAnn AnnListItem),
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcRn
LocatedN Name
sel_lname)
[] GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
unit_rhs]
| Bool
otherwise = (ConLike
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn))))
-> [ConLike]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
forall a b. (a -> b) -> [a] -> [b]
map ConLike
-> LMatch
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn))
ConLike
-> GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))
mk_match [ConLike]
cons_w_field [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
-> [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
deflt
mk_match :: ConLike
-> LMatch
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn))
mk_match ConLike
con = HsMatchContext GhcRn
-> [LPat GhcRn]
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
-> LMatch
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnn' (EpAnn AnnListItem),
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (LIdP GhcRn -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcRn
LocatedN Name
sel_lname)
[SrcSpanAnn' (EpAnn AnnListItem)
-> Pat GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc' (ConLike -> Pat GhcRn
mk_sel_pat ConLike
con)]
(SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc' (XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
locn Name
field_var)))
mk_sel_pat :: ConLike -> Pat GhcRn
mk_sel_pat ConLike
con = XConPat GhcRn
-> XRec GhcRn (ConLikeP GhcRn)
-> HsConPatDetails GhcRn
-> Pat GhcRn
forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat NoExtField
XConPat GhcRn
NoExtField (SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
locn (ConLike -> Name
forall a. NamedThing a => a -> Name
getName ConLike
con)) (HsRecFields
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))
-> HsConDetails
(HsPatSigType GhcRn)
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))
(HsRecFields
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon HsRecFields
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))
rec_fields)
rec_fields :: HsRecFields
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))
rec_fields = HsRecFields :: forall p arg.
[LHsRecField p arg]
-> Maybe (Located BranchIndex) -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))]
rec_flds = [LHsRecField
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))
LocatedAn
AnnListItem
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)))
rec_field], rec_dotdot :: Maybe (Located BranchIndex)
rec_dotdot = Maybe (Located BranchIndex)
forall a. Maybe a
Nothing }
rec_field :: LocatedAn
AnnListItem
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)))
rec_field = HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn))
-> LocatedAn
AnnListItem
(HsFieldBind
(GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)))
forall a an. a -> LocatedAn an a
noLocA (HsFieldBind :: forall lhs rhs.
XHsFieldBind lhs -> lhs -> rhs -> Bool -> HsFieldBind lhs rhs
HsFieldBind
{ hfbAnn :: XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
hfbAnn = XHsFieldBind (GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn))
forall a. EpAnn a
noAnn
, hfbLHS :: GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
hfbLHS
= SrcAnn NoEpAnns
-> FieldOcc GhcRn -> GenLocated (SrcAnn NoEpAnns) (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcAnn NoEpAnns
locc (XCFieldOcc GhcRn -> XRec GhcRn RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> XRec pass RdrName -> FieldOcc pass
FieldOcc XCFieldOcc GhcRn
Name
sel_name
(SrcAnn NameAnn -> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
locn (RdrName -> GenLocated (SrcAnn NameAnn) RdrName)
-> RdrName -> GenLocated (SrcAnn NameAnn) RdrName
forall a b. (a -> b) -> a -> b
$ FieldLabelString -> RdrName
mkVarUnqual FieldLabelString
lbl))
, hfbRHS :: GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)
hfbRHS
= SrcSpanAnn' (EpAnn AnnListItem)
-> Pat GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc' (XVarPat GhcRn -> LIdP GhcRn -> Pat GhcRn
forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
XVarPat GhcRn
noExtField (SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
locn Name
field_var))
, hfbPun :: Bool
hfbPun = Bool
False })
sel_lname :: LocatedN Name
sel_lname = SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
locn Name
sel_name
field_var :: Name
field_var = Unique -> OccName -> SrcSpan -> Name
mkInternalName (BranchIndex -> Unique
mkBuiltinUnique BranchIndex
1) (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
sel_name) SrcSpan
loc
deflt :: [GenLocated
(SrcSpanAnn' (EpAnn AnnListItem))
(Match
GhcRn
(GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)))]
deflt | (ConLike -> Bool) -> [ConLike] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConLike -> Bool
dealt_with [ConLike]
all_cons = []
| Bool
otherwise = [HsMatchContext GhcRn
-> [LPat GhcRn]
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
-> LMatch
GhcRn (GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnn' (EpAnn AnnListItem),
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext GhcRn
forall p. HsMatchContext p
CaseAlt
[SrcSpanAnn' (EpAnn AnnListItem)
-> Pat GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc' (XWildPat GhcRn -> Pat GhcRn
forall p. XWildPat p -> Pat p
WildPat NoExtField
XWildPat GhcRn
noExtField)]
(LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc' (XVar GhcRn -> LIdP GhcRn -> HsExpr GhcRn
forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField
(SrcAnn NameAnn -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcAnn NameAnn
locn (Var -> Name
forall a. NamedThing a => a -> Name
getName Var
rEC_SEL_ERROR_ID))))
(SrcSpanAnn' (EpAnn AnnListItem)
-> HsExpr GhcRn
-> GenLocated (SrcSpanAnn' (EpAnn AnnListItem)) (HsExpr GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn AnnListItem)
loc' (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
EpAnnCO
noComments HsLit GhcRn
msg_lit)))]
dealt_with :: ConLike -> Bool
dealt_with :: ConLike -> Bool
dealt_with (PatSynCon PatSyn
_) = Bool
False
dealt_with con :: ConLike
con@(RealDataCon DataCon
dc) =
ConLike
con ConLike -> [ConLike] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ConLike]
cons_w_field Bool -> Bool -> Bool
|| [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys DataCon
dc
([Var]
univ_tvs, [Var]
_, [EqSpec]
eq_spec, [Type]
_, [Type]
req_theta, [Scaled Type]
_, Type
data_ty) = ConLike
-> ([Var], [Var], [EqSpec], [Type], [Type], [Scaled Type], Type)
conLikeFullSig ConLike
con1
eq_subst :: TCvSubst
eq_subst = [(Var, Type)] -> TCvSubst
mkTvSubstPrs ((EqSpec -> (Var, Type)) -> [EqSpec] -> [(Var, Type)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (Var, Type)
eqSpecPair [EqSpec]
eq_spec)
inst_tys :: [Type]
inst_tys = TCvSubst -> [Var] -> [Type]
substTyVars TCvSubst
eq_subst [Var]
univ_tvs
unit_rhs :: LHsExpr GhcRn
unit_rhs = [LHsExpr GhcRn] -> XExplicitTuple GhcRn -> LHsExpr GhcRn
forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsTupleExpr [] NoExtField
XExplicitTuple GhcRn
noExtField
msg_lit :: HsLit GhcRn
msg_lit = XHsStringPrim GhcRn -> ByteString -> HsLit GhcRn
forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim XHsStringPrim GhcRn
SourceText
NoSourceText (FieldLabelString -> ByteString
bytesFS FieldLabelString
lbl)