{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.TyCl.Utils(
RolesInfo,
inferRoles,
checkSynCycles,
checkClassCycles,
addTyConsToGblEnv, mkDefaultMethodType,
tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Gen.Bind( tcValBinds )
import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
import GHC.Core.Multiplicity
import GHC.Tc.Utils.TcType
import GHC.Core.Predicate
import GHC.Builtin.Types( unitTy )
import GHC.Core.Make( rEC_SEL_ERROR_ID )
import GHC.Hs
import GHC.Core.Class
import GHC.Core.Type
import GHC.Driver.Types
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set hiding (unitFV)
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.Core.Coercion ( ltRole )
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Types.Unique ( mkBuiltinUnique )
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Utils.FV as FV
import GHC.Unit.Module
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
synonymTyConsOfType :: Type -> [TyCon]
synonymTyConsOfType :: PredType -> [TyCon]
synonymTyConsOfType PredType
ty
= NameEnv TyCon -> [TyCon]
forall a. NameEnv a -> [a]
nameEnvElts (PredType -> NameEnv TyCon
go PredType
ty)
where
go :: Type -> NameEnv TyCon
go :: PredType -> NameEnv TyCon
go (TyConApp TyCon
tc [PredType]
tys) = TyCon -> NameEnv TyCon
go_tc TyCon
tc NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` [PredType] -> NameEnv TyCon
forall {t :: * -> *}. Foldable t => t PredType -> NameEnv TyCon
go_s [PredType]
tys
go (LitTy TyLit
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go (TyVarTy Id
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go (AppTy PredType
a PredType
b) = PredType -> NameEnv TyCon
go PredType
a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
b
go (FunTy AnonArgFlag
_ PredType
w PredType
a PredType
b) = PredType -> NameEnv TyCon
go PredType
w NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
b
go (ForAllTy TyCoVarBinder
_ PredType
ty) = PredType -> NameEnv TyCon
go PredType
ty
go (CastTy PredType
ty KindCoercion
co) = PredType -> NameEnv TyCon
go PredType
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 PredType
ty) = PredType -> NameEnv TyCon
go PredType
ty
go_co (GRefl Role
_ PredType
ty MCoercionN
mco) = PredType -> NameEnv TyCon
go PredType
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 Id
_ 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 Id
_) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_co (HoleCo {}) = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
go_co (AxiomInstCo CoAxiom Branched
_ Int
_ [KindCoercion]
cs) = [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cs
go_co (UnivCo UnivCoProvenance
p Role
_ PredType
ty PredType
ty') = UnivCoProvenance -> NameEnv TyCon
go_prov UnivCoProvenance
p NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
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
_ Int
_ 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 UnivCoProvenance
CorePrepProv = 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 PredType -> NameEnv TyCon
go_s t PredType
tys = (PredType -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> t PredType -> 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)
-> (PredType -> NameEnv TyCon)
-> PredType
-> NameEnv TyCon
-> NameEnv TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredType -> NameEnv TyCon
go) NameEnv TyCon
forall a. NameEnv a
emptyNameEnv t PredType
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 {
forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
deriving ((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
<$ :: forall a b. a -> SynCycleM b -> SynCycleM a
$c<$ :: forall a b. a -> SynCycleM b -> SynCycleM a
fmap :: forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
$cfmap :: forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
Functor)
type SynCycleState = NameSet
instance Applicative SynCycleM where
pure :: forall a. 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)
<*> :: forall a b. 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 >>= :: forall a b. 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)
checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
checkNameIsAcyclic Name
n 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 Name
n Name -> SynCycleState -> Bool
`elemNameSet` 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 -> Name -> SynCycleState
extendNameSet SynCycleState
s' Name
n)
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 = do
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
emptyNameSet []) [TyCon]
tcs) SynCycleState
emptyNameSet 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
$ SDoc -> TcM ()
forall a. SDoc -> TcM a
failWithTc SDoc
err
Right ((), SynCycleState)
_ -> () -> TcM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
lcl_decls :: NameEnv (LTyClDecl GhcRn)
lcl_decls = [(Name, LTyClDecl GhcRn)] -> NameEnv (LTyClDecl GhcRn)
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ([Name] -> [LTyClDecl GhcRn] -> [(Name, LTyClDecl 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]
tyclds)
go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
go :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc =
Name -> SynCycleM () -> SynCycleM ()
checkNameIsAcyclic (TyCon -> Name
tyConName 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' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
go' :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go' SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc
| Name
n Name -> SynCycleState -> Bool
`elemNameSet` 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:"
, Int -> SDoc -> SDoc
nest Int
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 PredType
ty <- TyCon -> Maybe PredType
synTyConRhs_maybe TyCon
tc =
SynCycleState -> [TyCon] -> PredType -> SynCycleM ()
go_ty (SynCycleState -> Name -> SynCycleState
extendNameSet SynCycleState
so_far (TyCon -> Name
tyConName TyCon
tc)) (TyCon
tcTyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
:[TyCon]
seen_tcs) PredType
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 (LTyClDecl GhcRn) -> Name -> Maybe (LTyClDecl GhcRn)
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (LTyClDecl GhcRn)
lcl_decls Name
n of
Just (L SrcSpan
loc TyClDecl GhcRn
decl) -> SrcSpan -> SDoc
forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> TyClDecl GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyClDecl GhcRn
decl
Maybe (LTyClDecl 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 :: NameSet -> [TyCon] -> Type -> SynCycleM ()
go_ty :: SynCycleState -> [TyCon] -> PredType -> SynCycleM ()
go_ty SynCycleState
so_far [TyCon]
seen_tcs PredType
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) (PredType -> [TyCon]
synonymTyConsOfType PredType
ty)
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles Class
cls
= do { (Bool
definite_cycle, SDoc
err) <- SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
go (Name -> SynCycleState
unitNameSet (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls))
Class
cls ([Id] -> [PredType]
mkTyVarTys (Class -> [Id]
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)
, Int -> SDoc -> SDoc
nest Int
2 SDoc
err, SDoc
hint]) }
where
hint :: SDoc
hint = String -> SDoc
text String
"Use UndecidableSuperClasses to accept this"
go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go :: SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
go SynCycleState
so_far Class
cls [PredType]
tys = [Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc)
forall a. [Maybe a] -> Maybe a
firstJusts ([Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc))
-> [Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc)
forall a b. (a -> b) -> a -> b
$
(PredType -> Maybe (Bool, SDoc))
-> [PredType] -> [Maybe (Bool, SDoc)]
forall a b. (a -> b) -> [a] -> [b]
map (SynCycleState -> PredType -> Maybe (Bool, SDoc)
go_pred SynCycleState
so_far) ([PredType] -> [Maybe (Bool, SDoc)])
-> [PredType] -> [Maybe (Bool, SDoc)]
forall a b. (a -> b) -> a -> b
$
Class -> [PredType] -> [PredType]
immSuperClasses Class
cls [PredType]
tys
go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
go_pred :: SynCycleState -> PredType -> Maybe (Bool, SDoc)
go_pred SynCycleState
so_far PredType
pred
| Just (TyCon
tc, [PredType]
tys) <- HasCallStack => PredType -> Maybe (TyCon, [PredType])
PredType -> Maybe (TyCon, [PredType])
tcSplitTyConApp_maybe PredType
pred
= SynCycleState
-> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
go_tc SynCycleState
so_far PredType
pred TyCon
tc [PredType]
tys
| PredType -> Bool
hasTyVarHead PredType
pred
= (Bool, SDoc) -> Maybe (Bool, SDoc)
forall a. a -> Maybe a
Just (Bool
False, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"one of whose superclass constraints is headed by a type variable:")
Int
2 (SDoc -> SDoc
quotes (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
pred)))
| Bool
otherwise
= Maybe (Bool, SDoc)
forall a. Maybe a
Nothing
go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc :: SynCycleState
-> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
go_tc SynCycleState
so_far PredType
pred TyCon
tc [PredType]
tys
| TyCon -> Bool
isFamilyTyCon TyCon
tc
= (Bool, SDoc) -> Maybe (Bool, SDoc)
forall a. a -> Maybe a
Just (Bool
False, SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"one of whose superclass constraints is headed by a type family:")
Int
2 (SDoc -> SDoc
quotes (PredType -> SDoc
forall a. Outputable a => a -> SDoc
ppr PredType
pred)))
| Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
= SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
go_cls SynCycleState
so_far Class
cls [PredType]
tys
| Bool
otherwise
= Maybe (Bool, SDoc)
forall a. Maybe a
Nothing
go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls :: SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
go_cls SynCycleState
so_far Class
cls [PredType]
tys
| Name
cls_nm Name -> SynCycleState -> Bool
`elemNameSet` SynCycleState
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
= SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
go SynCycleState
so_far Class
cls [PredType]
tys
| Bool
otherwise
= do { (Bool
b,SDoc
err) <- SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
go (SynCycleState
so_far SynCycleState -> Name -> SynCycleState
`extendNameSet` Name
cls_nm) Class
cls [PredType]
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) }
where
cls_nm :: Name
cls_nm = Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls
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 :: Int
num_exps = (ArgFlag -> Bool) -> [ArgFlag] -> Int
forall a. (a -> Bool) -> [a] -> Int
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 SrcSpan
_ (RoleAnnotDecl XCRoleAnnotDecl GhcRn
_ Located (IdP GhcRn)
_ [Located (Maybe Role)]
annots))
| [Located (Maybe Role)]
annots [Located (Maybe Role)] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthIs` Int
num_exps -> (Located (Maybe Role) -> Maybe Role)
-> [Located (Maybe Role)] -> [Maybe Role]
forall a b. (a -> b) -> [a] -> [b]
map Located (Maybe Role) -> Maybe Role
forall l e. GenLocated l e -> e
unLoc [Located (Maybe Role)]
annots
Maybe (LRoleAnnotDecl GhcRn)
_ -> Int -> Maybe Role -> [Maybe Role]
forall a. Int -> a -> [a]
replicate Int
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 { (PredType -> RoleM ()) -> [PredType] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> PredType -> RoleM ()
irType VarSet
emptyVarSet) (TyCon -> [PredType]
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 PredType
ty <- TyCon -> Maybe PredType
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 -> PredType -> RoleM ()
irType VarSet
emptyVarSet PredType
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 :: [Id]
cls_tvs = Class -> [Id]
classTyVars Class
cls
cls_tv_set :: VarSet
cls_tv_set = [Id] -> VarSet
mkVarSet [Id]
cls_tvs
ir_at :: TyCon -> RoleM ()
ir_at TyCon
at_tc
= (Id -> RoleM ()) -> [Id] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Role -> Id -> RoleM ()
updateRole Role
Nominal) [Id]
nvars
where nvars :: [Id]
nvars = (Id -> Bool) -> [Id] -> [Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` VarSet
cls_tv_set) ([Id] -> [Id]) -> [Id] -> [Id]
forall a b. (a -> b) -> a -> b
$ TyCon -> [Id]
tyConTyVars TyCon
at_tc
irDataCon :: DataCon -> RoleM ()
irDataCon :: DataCon -> RoleM ()
irDataCon DataCon
datacon
= [Id] -> RoleM () -> RoleM ()
forall a. [Id] -> RoleM a -> RoleM a
setRoleInferenceVars [Id]
univ_tvs (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
[Id] -> (VarSet -> RoleM ()) -> RoleM ()
forall a. [Id] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [Id]
ex_tvs ((VarSet -> RoleM ()) -> RoleM ())
-> (VarSet -> RoleM ()) -> RoleM ()
forall a b. (a -> b) -> a -> b
$ \ VarSet
ex_var_set ->
do (PredType -> RoleM ()) -> [PredType] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> PredType -> RoleM ()
irType VarSet
ex_var_set) ([EqSpec] -> [PredType]
eqSpecPreds [EqSpec]
eq_spec [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ [PredType]
theta [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ (Scaled PredType -> PredType) -> [Scaled PredType] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled PredType -> PredType
forall a. Scaled a -> a
scaledThing [Scaled PredType]
arg_tys)
(PredType -> RoleM ()) -> [PredType] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> PredType -> RoleM ()
markNominal VarSet
ex_var_set) ((Id -> PredType) -> [Id] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
tyVarKind [Id]
ex_tvs [PredType] -> [PredType] -> [PredType]
forall a. [a] -> [a] -> [a]
++ (Scaled PredType -> PredType) -> [Scaled PredType] -> [PredType]
forall a b. (a -> b) -> [a] -> [b]
map Scaled PredType -> PredType
forall a. Scaled a -> PredType
scaledMult [Scaled PredType]
arg_tys)
where
([Id]
univ_tvs, [Id]
ex_tvs, [EqSpec]
eq_spec, [PredType]
theta, [Scaled PredType]
arg_tys, PredType
_res_ty)
= DataCon
-> ([Id], [Id], [EqSpec], [PredType], [Scaled PredType], PredType)
dataConFullSig DataCon
datacon
irType :: VarSet -> Type -> RoleM ()
irType :: VarSet -> PredType -> RoleM ()
irType = VarSet -> PredType -> RoleM ()
go
where
go :: VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
ty | Just PredType
ty' <- PredType -> Maybe PredType
coreView PredType
ty
= VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
ty'
go VarSet
lcls (TyVarTy Id
tv) = Bool -> RoleM () -> RoleM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
lcls) (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
Role -> Id -> RoleM ()
updateRole Role
Representational Id
tv
go VarSet
lcls (AppTy PredType
t1 PredType
t2) = VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
t1 RoleM () -> RoleM () -> RoleM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
markNominal VarSet
lcls PredType
t2
go VarSet
lcls (TyConApp TyCon
tc [PredType]
tys) = do { [Role]
roles <- TyCon -> RoleM [Role]
lookupRolesX TyCon
tc
; (Role -> PredType -> RoleM ()) -> [Role] -> [PredType] -> RoleM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (VarSet -> Role -> PredType -> RoleM ()
go_app VarSet
lcls) [Role]
roles [PredType]
tys }
go VarSet
lcls (ForAllTy TyCoVarBinder
tvb PredType
ty) = do { let tv :: Id
tv = TyCoVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar TyCoVarBinder
tvb
lcls' :: VarSet
lcls' = VarSet -> Id -> VarSet
extendVarSet VarSet
lcls Id
tv
; VarSet -> PredType -> RoleM ()
markNominal VarSet
lcls (Id -> PredType
tyVarKind Id
tv)
; VarSet -> PredType -> RoleM ()
go VarSet
lcls' PredType
ty }
go VarSet
lcls (FunTy AnonArgFlag
_ PredType
w PredType
arg PredType
res) = VarSet -> PredType -> RoleM ()
markNominal VarSet
lcls PredType
w RoleM () -> RoleM () -> RoleM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
arg RoleM () -> RoleM () -> RoleM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
res
go VarSet
_ (LitTy {}) = () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go VarSet
lcls (CastTy PredType
ty KindCoercion
_) = VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
ty
go VarSet
_ (CoercionTy KindCoercion
_) = () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_app :: VarSet -> Role -> PredType -> RoleM ()
go_app VarSet
_ Role
Phantom PredType
_ = () -> RoleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_app VarSet
lcls Role
Nominal PredType
ty = VarSet -> PredType -> RoleM ()
markNominal VarSet
lcls PredType
ty
go_app VarSet
lcls Role
Representational PredType
ty = VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
ty
irTcTyVars :: TyCon -> RoleM a -> RoleM a
irTcTyVars :: forall a. 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
$ [Id] -> RoleM a
go (TyCon -> [Id]
tyConTyVars TyCon
tc)
where
go :: [Id] -> RoleM a
go [] = RoleM a
thing
go (Id
tv:[Id]
tvs) = do { VarSet -> PredType -> RoleM ()
markNominal VarSet
emptyVarSet (Id -> PredType
tyVarKind Id
tv)
; Id -> RoleM a -> RoleM a
forall a. Id -> RoleM a -> RoleM a
addRoleInferenceVar Id
tv (RoleM a -> RoleM a) -> RoleM a -> RoleM a
forall a b. (a -> b) -> a -> b
$ [Id] -> RoleM a
go [Id]
tvs }
irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a
irExTyVars :: forall a. [Id] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [Id]
orig_tvs VarSet -> RoleM a
thing = VarSet -> [Id] -> RoleM a
go VarSet
emptyVarSet [Id]
orig_tvs
where
go :: VarSet -> [Id] -> RoleM a
go VarSet
lcls [] = VarSet -> RoleM a
thing VarSet
lcls
go VarSet
lcls (Id
tv:[Id]
tvs) = do { VarSet -> PredType -> RoleM ()
markNominal VarSet
lcls (Id -> PredType
tyVarKind Id
tv)
; VarSet -> [Id] -> RoleM a
go (VarSet -> Id -> VarSet
extendVarSet VarSet
lcls Id
tv) [Id]
tvs }
markNominal :: TyVarSet
-> Type -> RoleM ()
markNominal :: VarSet -> PredType -> RoleM ()
markNominal VarSet
lcls PredType
ty = let nvars :: [Id]
nvars = FV -> [Id]
fvVarList (VarSet -> FV -> FV
FV.delFVs VarSet
lcls (FV -> FV) -> FV -> FV
forall a b. (a -> b) -> a -> b
$ PredType -> FV
get_ty_vars PredType
ty) in
(Id -> RoleM ()) -> [Id] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Role -> Id -> RoleM ()
updateRole Role
Nominal) [Id]
nvars
where
get_ty_vars :: Type -> FV
get_ty_vars :: PredType -> FV
get_ty_vars (TyVarTy Id
tv) = Id -> FV
unitFV Id
tv
get_ty_vars (AppTy PredType
t1 PredType
t2) = PredType -> FV
get_ty_vars PredType
t1 FV -> FV -> FV
`unionFV` PredType -> FV
get_ty_vars PredType
t2
get_ty_vars (FunTy AnonArgFlag
_ PredType
w PredType
t1 PredType
t2) = PredType -> FV
get_ty_vars PredType
w FV -> FV -> FV
`unionFV` PredType -> FV
get_ty_vars PredType
t1 FV -> FV -> FV
`unionFV` PredType -> FV
get_ty_vars PredType
t2
get_ty_vars (TyConApp TyCon
_ [PredType]
tys) = (PredType -> FV) -> [PredType] -> FV
forall a. (a -> FV) -> [a] -> FV
mapUnionFV PredType -> FV
get_ty_vars [PredType]
tys
get_ty_vars (ForAllTy TyCoVarBinder
tvb PredType
ty) = TyCoVarBinder -> FV -> FV
tyCoFVsBndr TyCoVarBinder
tvb (PredType -> FV
get_ty_vars PredType
ty)
get_ty_vars (LitTy {}) = FV
emptyFV
get_ty_vars (CastTy PredType
ty KindCoercion
_) = PredType -> FV
get_ty_vars PredType
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 -> Id -> RoleM ()
updateRole Role
role Id
tv
= do { VarPositions
var_ns <- RoleM VarPositions
getVarNs
; Name
name <- RoleM Name
getTyConName
; case VarPositions -> Id -> Maybe Int
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarPositions
var_ns Id
tv of
Maybe Int
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
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> SDoc
$$ VarPositions -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarPositions
var_ns)
Just Int
n -> Name -> Int -> Role -> RoleM ()
updateRoleEnv Name
name Int
n Role
role }
data RoleInferenceState = RIS { RoleInferenceState -> RoleEnv
role_env :: RoleEnv
, RoleInferenceState -> Bool
update :: Bool }
type VarPositions = VarEnv Int
newtype RoleM a = RM { forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM :: Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState) }
deriving ((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
<$ :: forall a b. a -> RoleM b -> RoleM a
$c<$ :: forall a b. a -> RoleM b -> RoleM a
fmap :: forall a b. (a -> b) -> RoleM a -> RoleM b
$cfmap :: forall a b. (a -> b) -> RoleM a -> RoleM b
Functor)
instance Applicative RoleM where
pure :: forall a. a -> RoleM a
pure a
x = (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
_ Int
_ RoleInferenceState
state -> (a
x, RoleInferenceState
state)
<*> :: forall a b. 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 >>= :: forall a b. RoleM a -> (a -> RoleM b) -> RoleM b
>>= a -> RoleM b
f = (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (b, RoleInferenceState))
-> RoleM b
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (b, RoleInferenceState))
-> RoleM b)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (b, RoleInferenceState))
-> RoleM b
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_info VarPositions
vps Int
nvps RoleInferenceState
state ->
let (a
a', RoleInferenceState
state') = RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
a Maybe Name
m_info VarPositions
vps Int
nvps RoleInferenceState
state in
RoleM b
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (b, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM (a -> RoleM b
f a
a') Maybe Name
m_info VarPositions
vps Int
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
-> Int
-> RoleInferenceState
-> ((), RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM ()
thing Maybe Name
forall a. Maybe a
Nothing VarPositions
forall a. VarEnv a
emptyVarEnv Int
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 :: forall a. Name -> RoleM a -> RoleM a
setRoleInferenceTc Name
name RoleM a
thing = (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
vps Int
nvps RoleInferenceState
state ->
ASSERT( isNothing m_name )
ASSERT( isEmptyVarEnv vps )
ASSERT( nvps == 0 )
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name) VarPositions
vps Int
nvps RoleInferenceState
state
addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
addRoleInferenceVar :: forall a. Id -> RoleM a -> RoleM a
addRoleInferenceVar Id
tv RoleM a
thing
= (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
vps Int
nvps RoleInferenceState
state ->
ASSERT( isJust m_name )
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name (VarPositions -> Id -> Int -> VarPositions
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarPositions
vps Id
tv Int
nvps) (Int
nvpsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) RoleInferenceState
state
setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
setRoleInferenceVars :: forall a. [Id] -> RoleM a -> RoleM a
setRoleInferenceVars [Id]
tvs RoleM a
thing
= (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_vps Int
_nvps RoleInferenceState
state ->
ASSERT( isJust m_name )
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name ([(Id, Int)] -> VarPositions
forall a. [(Id, a)] -> VarEnv a
mkVarEnv ([Id] -> [Int] -> [(Id, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
tvs [Int
0..])) (String -> Int
forall a. String -> a
panic String
"setRoleInferenceVars")
RoleInferenceState
state
getRoleEnv :: RoleM RoleEnv
getRoleEnv :: RoleM RoleEnv
getRoleEnv = (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (RoleEnv, RoleInferenceState))
-> RoleM RoleEnv
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (RoleEnv, RoleInferenceState))
-> RoleM RoleEnv)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (RoleEnv, RoleInferenceState))
-> RoleM RoleEnv
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
_ Int
_ 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
-> Int
-> RoleInferenceState
-> (VarPositions, RoleInferenceState))
-> RoleM VarPositions
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (VarPositions, RoleInferenceState))
-> RoleM VarPositions)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (VarPositions, RoleInferenceState))
-> RoleM VarPositions
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
vps Int
_ RoleInferenceState
state -> (VarPositions
vps, RoleInferenceState
state)
getTyConName :: RoleM Name
getTyConName :: RoleM Name
getTyConName = (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (Name, RoleInferenceState))
-> RoleM Name
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (Name, RoleInferenceState))
-> RoleM Name)
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (Name, RoleInferenceState))
-> RoleM Name
forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_ Int
_ 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 -> Int -> Role -> RoleM ()
updateRoleEnv Name
name Int
n Role
role
= (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> ((), RoleInferenceState))
-> RoleM ()
forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM ((Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> ((), RoleInferenceState))
-> RoleM ())
-> (Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> ((), RoleInferenceState))
-> RoleM ()
forall a b. (a -> b) -> a -> b
$ \Maybe Name
_ VarPositions
_ Int
_ 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) = Int -> [Role] -> ([Role], [Role])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
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
addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
addTyConsToGblEnv [TyCon]
tyclss
= [TyCon] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tyclss (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
[TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
implicit_things (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
[Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
def_meth_ids (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
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 <- [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds ([TyCon] -> [(Id, LHsBind GhcRn)]
mkRecSelBinds [TyCon]
tyclss)
; TcGblEnv -> TcM TcGblEnv
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
gbl_env }
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 :: [Id]
def_meth_ids = [TyCon] -> [Id]
mkDefaultMethodIds [TyCon]
tyclss
mkDefaultMethodIds :: [TyCon] -> [Id]
mkDefaultMethodIds :: [TyCon] -> [Id]
mkDefaultMethodIds [TyCon]
tycons
= [ Name -> PredType -> Id
mkExportedVanillaId Name
dm_name (Class -> Id -> DefMethSpec PredType -> PredType
mkDefaultMethodType Class
cls Id
sel_id DefMethSpec PredType
dm_spec)
| TyCon
tc <- [TyCon]
tycons
, Just Class
cls <- [TyCon -> Maybe Class
tyConClass_maybe TyCon
tc]
, (Id
sel_id, Just (Name
dm_name, DefMethSpec PredType
dm_spec)) <- Class -> [(Id, DefMethInfo)]
classOpItems Class
cls ]
mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
mkDefaultMethodType :: Class -> Id -> DefMethSpec PredType -> PredType
mkDefaultMethodType Class
_ Id
sel_id DefMethSpec PredType
VanillaDM = Id -> PredType
idType Id
sel_id
mkDefaultMethodType Class
cls Id
_ (GenericDM PredType
dm_ty) = [TyCoVarBinder] -> [PredType] -> PredType -> PredType
mkSigmaTy [TyCoVarBinder]
tv_bndrs [PredType
pred] PredType
dm_ty
where
pred :: PredType
pred = Class -> [PredType] -> PredType
mkClassPred Class
cls ([Id] -> [PredType]
mkTyVarTys ([TyConBinder] -> [Id]
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 Id Specificity] -> [TyCoVarBinder]
forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders ([VarBndr Id Specificity] -> [TyCoVarBinder])
-> [VarBndr Id Specificity] -> [TyCoVarBinder]
forall a b. (a -> b) -> a -> b
$ [TyConBinder] -> [VarBndr Id Specificity]
tyConInvisTVBinders [TyConBinder]
cls_bndrs
tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds [(Id, LHsBind GhcRn)]
sel_bind_prs
= [Id] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
sel_id | (L SrcSpan
_ (IdSig XIdSig GhcRn
_ Id
sel_id)) <- [GenLocated SrcSpan (Sig GhcRn)]
sigs] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
do { ([(RecFlag, LHsBinds GhcTc)]
rec_sel_binds, TcGblEnv
tcg_env) <- TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
forall a. TcRn a -> TcRn a
discardWarnings (TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv))
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
forall a b. (a -> b) -> a -> b
$
Extension
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ImpredicativeTypes (TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv))
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
forall a b. (a -> b) -> a -> b
$
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [GenLocated SrcSpan (Sig GhcRn)]
-> TcM TcGblEnv
-> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [GenLocated SrcSpan (Sig GhcRn)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag, LHsBinds GhcRn)]
binds [GenLocated SrcSpan (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, LHsBinds GhcTc) -> LHsBinds GhcTc)
-> [(RecFlag, LHsBinds GhcTc)] -> [LHsBinds GhcTc]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, LHsBinds GhcTc) -> LHsBinds GhcTc
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcTc)]
rec_sel_binds) }
where
sigs :: [GenLocated SrcSpan (Sig GhcRn)]
sigs = [ SrcSpan -> Sig GhcRn -> GenLocated SrcSpan (Sig GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XIdSig GhcRn -> Id -> Sig GhcRn
forall pass. XIdSig pass -> Id -> Sig pass
IdSig NoExtField
XIdSig GhcRn
noExtField Id
sel_id) | (Id
sel_id, LHsBind GhcRn
_) <- [(Id, LHsBind GhcRn)]
sel_bind_prs
, let loc :: SrcSpan
loc = Id -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
sel_id ]
binds :: [(RecFlag, LHsBinds GhcRn)]
binds = [(RecFlag
NonRecursive, LHsBind GhcRn -> LHsBinds GhcRn
forall a. a -> Bag a
unitBag LHsBind GhcRn
bind) | (Id
_, LHsBind GhcRn
bind) <- [(Id, LHsBind GhcRn)]
sel_bind_prs]
mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
mkRecSelBinds [TyCon]
tycons
= ((TyCon, FieldLabel) -> (Id, LHsBind GhcRn))
-> [(TyCon, FieldLabel)] -> [(Id, LHsBind GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon, FieldLabel) -> (Id, LHsBind 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) -> (Id, LHsBind GhcRn)
mkRecSelBind (TyCon
tycon, FieldLabel
fl)
= [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn)
mkOneRecordSelector [ConLike]
all_cons (TyCon -> RecSelParent
RecSelData TyCon
tycon) FieldLabel
fl
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
-> (Id, LHsBind GhcRn)
mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn)
mkOneRecordSelector [ConLike]
all_cons RecSelParent
idDetails FieldLabel
fl
= (Id
sel_id, SrcSpan -> HsBind GhcRn -> LHsBind GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsBind GhcRn
sel_bind)
where
loc :: SrcSpan
loc = Name -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
sel_name
lbl :: FieldLabelString
lbl = FieldLabel -> FieldLabelString
forall a. FieldLbl a -> FieldLabelString
flLabel FieldLabel
fl
sel_name :: Name
sel_name = FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl
sel_id :: Id
sel_id = IdDetails -> Name -> PredType -> Id
mkExportedLocalId IdDetails
rec_details Name
sel_name PredType
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 = ASSERT( not (null cons_w_field) ) head cons_w_field
field_ty :: PredType
field_ty = ConLike -> FieldLabelString -> PredType
conLikeFieldType ConLike
con1 FieldLabelString
lbl
data_tvbs :: [VarBndr Id Specificity]
data_tvbs = (VarBndr Id Specificity -> Bool)
-> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
forall a. (a -> Bool) -> [a] -> [a]
filter (\VarBndr Id Specificity
tvb -> VarBndr Id Specificity -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar VarBndr Id Specificity
tvb Id -> VarSet -> Bool
`elemVarSet` VarSet
data_tv_set) ([VarBndr Id Specificity] -> [VarBndr Id Specificity])
-> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
forall a b. (a -> b) -> a -> b
$
ConLike -> [VarBndr Id Specificity]
conLikeUserTyVarBinders ConLike
con1
data_tv_set :: VarSet
data_tv_set= [PredType] -> VarSet
tyCoVarsOfTypes [PredType]
inst_tys
is_naughty :: Bool
is_naughty = Bool -> Bool
not (PredType -> VarSet
tyCoVarsOfType PredType
field_ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
data_tv_set)
sel_ty :: PredType
sel_ty | Bool
is_naughty = PredType
unitTy
| Bool
otherwise = [TyCoVarBinder] -> PredType -> PredType
mkForAllTys ([VarBndr Id Specificity] -> [TyCoVarBinder]
forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders [VarBndr Id Specificity]
data_tvbs) (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$
[PredType] -> PredType -> PredType
mkPhiTy (ConLike -> [PredType]
conLikeStupidTheta ConLike
con1) (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$
[PredType] -> PredType -> PredType
mkPhiTy [PredType]
req_theta (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$
PredType -> PredType -> PredType
mkVisFunTyMany PredType
data_ty (PredType -> PredType) -> PredType -> PredType
forall a b. (a -> b) -> a -> b
$
PredType
field_ty
sel_bind :: HsBind GhcRn
sel_bind = Origin
-> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn
mkTopFunBind Origin
Generated Located Name
sel_lname [LMatch GhcRn (LHsExpr GhcRn)]
alts
where
alts :: [LMatch GhcRn (LHsExpr GhcRn)]
alts | Bool
is_naughty = [HsMatchContext (NoGhcTc GhcRn)
-> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch (Located (IdP GhcRn) -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located Name
Located (IdP GhcRn)
sel_lname)
[] LHsExpr GhcRn
forall {a :: Pass}. LHsExpr (GhcPass a)
unit_rhs]
| Bool
otherwise = (ConLike -> LMatch GhcRn (LHsExpr GhcRn))
-> [ConLike] -> [LMatch GhcRn (LHsExpr GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ConLike -> LMatch GhcRn (LHsExpr GhcRn)
mk_match [ConLike]
cons_w_field [LMatch GhcRn (LHsExpr GhcRn)]
-> [LMatch GhcRn (LHsExpr GhcRn)] -> [LMatch GhcRn (LHsExpr GhcRn)]
forall a. [a] -> [a] -> [a]
++ [LMatch GhcRn (LHsExpr GhcRn)]
deflt
mk_match :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
mk_match ConLike
con = HsMatchContext (NoGhcTc GhcRn)
-> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch (Located (IdP GhcRn) -> HsMatchContext GhcRn
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located Name
Located (IdP GhcRn)
sel_lname)
[SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (ConLike -> Pat GhcRn
mk_sel_pat ConLike
con)]
(SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
field_var)))
mk_sel_pat :: ConLike -> Pat GhcRn
mk_sel_pat ConLike
con = XConPat GhcRn
-> Located (ConLikeP GhcRn) -> HsConPatDetails GhcRn -> Pat GhcRn
forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat NoExtField
XConPat GhcRn
NoExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (ConLike -> Name
forall a. NamedThing a => a -> Name
getName ConLike
con)) (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
-> HsConDetails
(GenLocated SrcSpan (Pat GhcRn))
(HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn)))
forall arg rec. rec -> HsConDetails arg rec
RecCon HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
rec_fields)
rec_fields :: HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
rec_fields = HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))]
rec_flds = [LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))
rec_field], rec_dotdot :: Maybe (Located Int)
rec_dotdot = Maybe (Located Int)
forall a. Maybe a
Nothing }
rec_field :: LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))
rec_field = HsRecField' (FieldOcc GhcRn) (GenLocated SrcSpan (Pat GhcRn))
-> LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))
forall e. e -> Located e
noLoc (HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField
{ hsRecFieldLbl :: Located (FieldOcc GhcRn)
hsRecFieldLbl
= SrcSpan -> FieldOcc GhcRn -> Located (FieldOcc GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc Name
XCFieldOcc GhcRn
sel_name
(SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ FieldLabelString -> RdrName
mkVarUnqual FieldLabelString
lbl))
, hsRecFieldArg :: GenLocated SrcSpan (Pat GhcRn)
hsRecFieldArg
= SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVarPat GhcRn -> Located (IdP GhcRn) -> Pat GhcRn
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat NoExtField
XVarPat GhcRn
noExtField (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
field_var))
, hsRecPun :: Bool
hsRecPun = Bool
False })
sel_lname :: Located Name
sel_lname = SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Name
sel_name
field_var :: Name
field_var = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique Int
1) (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
sel_name) SrcSpan
loc
deflt :: [LMatch GhcRn (LHsExpr 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 (NoGhcTc GhcRn)
-> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NoGhcTc GhcRn)
forall p. HsMatchContext p
CaseAlt
[SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
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 (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcRn
noExtField
(SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Id -> Name
forall a. NamedThing a => a -> Name
getName Id
rEC_SEL_ERROR_ID))))
(SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit NoExtField
XLitE GhcRn
noExtField 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
|| [PredType] -> DataCon -> Bool
dataConCannotMatch [PredType]
inst_tys DataCon
dc
([Id]
univ_tvs, [Id]
_, [EqSpec]
eq_spec, [PredType]
_, [PredType]
req_theta, [Scaled PredType]
_, PredType
data_ty) = ConLike
-> ([Id], [Id], [EqSpec], [PredType], [PredType],
[Scaled PredType], PredType)
conLikeFullSig ConLike
con1
eq_subst :: TCvSubst
eq_subst = [(Id, PredType)] -> TCvSubst
mkTvSubstPrs ((EqSpec -> (Id, PredType)) -> [EqSpec] -> [(Id, PredType)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (Id, PredType)
eqSpecPair [EqSpec]
eq_spec)
inst_tys :: [PredType]
inst_tys = TCvSubst -> [Id] -> [PredType]
substTyVars TCvSubst
eq_subst [Id]
univ_tvs
unit_rhs :: LHsExpr (GhcPass a)
unit_rhs = [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsTupleExpr []
msg_lit :: HsLit GhcRn
msg_lit = XHsStringPrim GhcRn -> ByteString -> HsLit GhcRn
forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
XHsStringPrim GhcRn
NoSourceText (FieldLabelString -> ByteString
bytesFS FieldLabelString
lbl)