{-# LANGUAGE CPP #-}
{-# 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
#include "GhclibHsVersions.h"
import GHC.Prelude
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.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.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 :: PredType -> [TyCon]
synonymTyConsOfType PredType
ty
= 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` forall {t :: * -> *}. Foldable t => t PredType -> NameEnv TyCon
go_s [PredType]
tys
go (LitTy TyLit
_) = forall a. NameEnv a
emptyNameEnv
go (TyVarTy Id
_) = forall a. NameEnv a
emptyNameEnv
go (AppTy PredType
a PredType
b) = PredType -> NameEnv TyCon
go PredType
a 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
a 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 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 = 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 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 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 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 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
go_co (CoVarCo Id
_) = forall a. NameEnv a
emptyNameEnv
go_co (HoleCo {}) = 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
ty 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 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 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
_) = forall a. NameEnv a
emptyNameEnv
go_prov (CorePrepProv Bool
_) = forall a. NameEnv a
emptyNameEnv
go_tc :: TyCon -> NameEnv TyCon
go_tc TyCon
tc | TyCon -> Bool
isTypeSynonymTyCon TyCon
tc = forall a. Name -> a -> NameEnv a
unitNameEnv (TyCon -> Name
tyConName TyCon
tc) TyCon
tc
| Bool
otherwise = forall a. NameEnv a
emptyNameEnv
go_s :: t PredType -> NameEnv TyCon
go_s t PredType
tys = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredType -> NameEnv TyCon
go) forall a. NameEnv a
emptyNameEnv t PredType
tys
go_co_s :: [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cos = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
. KindCoercion -> NameEnv TyCon
go_co) 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 -> 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 = TyConSet
instance Applicative SynCycleM where
pure :: forall a. a -> SynCycleM a
pure a
x = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \SynCycleState
state -> forall a b. b -> Either a b
Right (a
x, SynCycleState
state)
<*> :: forall a 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 = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \SynCycleState
state ->
case forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM SynCycleM a
m SynCycleState
state of
Right (a
x, SynCycleState
state') ->
forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM (a -> SynCycleM b
f a
x) SynCycleState
state'
Left (SrcSpan, SDoc)
err -> forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM SrcSpan
loc SDoc
err = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \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 = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \SynCycleState
s ->
if TyCon
tc TyCon -> SynCycleState -> Bool
`elemTyConSet` SynCycleState
s
then forall a b. b -> Either a b
Right ((), SynCycleState
s)
else case forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM SynCycleM ()
m SynCycleState
s of
Right ((), SynCycleState
s') -> forall a b. b -> Either a b
Right ((), SynCycleState -> TyCon -> SynCycleState
extendTyConSet SynCycleState
s' TyCon
tc)
Left (SrcSpan, SDoc)
err -> forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl (GhcPass 'Renamed)] -> TcM ()
checkSynCycles Unit
this_uid [TyCon]
tcs [LTyClDecl (GhcPass 'Renamed)]
tyclds =
case forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM (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) -> forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> TcM a
failWithTc SDoc
err
Right ((), SynCycleState)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
lcl_decls :: NameEnv (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)))
lcl_decls = forall a. [(Name, a)] -> NameEnv a
mkNameEnv (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
tyConName [TyCon]
tcs) [LTyClDecl (GhcPass 'Renamed)]
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 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 (forall a. NamedThing a => a -> SrcSpan
getSrcSpan (forall a. [a] -> a
head [TyCon]
seen_tcs)) 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 (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> SDoc
ppr_decl [TyCon]
seen_tcs)) ]
| Bool -> Bool
not (forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod Bool -> Bool -> Bool
||
forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
this_uid Bool -> Bool -> Bool
||
Module -> Bool
isInteractiveModule Module
mod)
= 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 -> TyCon -> SynCycleState
extendTyConSet SynCycleState
so_far TyCon
tc) (TyCon
tcforall a. a -> [a] -> [a]
:[TyCon]
seen_tcs) PredType
ty
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
n :: Name
n = TyCon -> Name
tyConName TyCon
tc
mod :: Module
mod = HasDebugCallStack => Name -> Module
nameModule Name
n
ppr_decl :: TyCon -> SDoc
ppr_decl TyCon
tc =
case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)))
lcl_decls Name
n of
Just (L SrcSpanAnnA
loc TyClDecl (GhcPass 'Renamed)
decl) -> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyClDecl (GhcPass 'Renamed)
decl
Maybe (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)))
Nothing -> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> 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] -> PredType -> SynCycleM ()
go_ty SynCycleState
so_far [TyCon]
seen_tcs PredType
ty =
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)
type ClassSet = UniqSet Class
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles Class
cls
= do { (Bool
definite_cycle, SDoc
err) <- ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go (forall a. Uniquable a => a -> UniqSet a
unitUniqSet 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"
; forall (m :: * -> *) a. Monad m => a -> m a
return ([SDoc] -> SDoc
vcat [ SDoc
herald SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (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 :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go :: ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go ClassSet
so_far Class
cls [PredType]
tys = forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (ClassSet -> PredType -> Maybe (Bool, SDoc)
go_pred ClassSet
so_far) forall a b. (a -> b) -> a -> b
$
Class -> [PredType] -> [PredType]
immSuperClasses Class
cls [PredType]
tys
go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
go_pred ClassSet
so_far PredType
pred
| Just (TyCon
tc, [PredType]
tys) <- HasCallStack => PredType -> Maybe (TyCon, [PredType])
tcSplitTyConApp_maybe PredType
pred
= ClassSet -> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
go_tc ClassSet
so_far PredType
pred TyCon
tc [PredType]
tys
| PredType -> Bool
hasTyVarHead PredType
pred
= 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 (forall a. Outputable a => a -> SDoc
ppr PredType
pred)))
| Bool
otherwise
= forall a. Maybe a
Nothing
go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc :: ClassSet -> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
go_tc ClassSet
so_far PredType
pred TyCon
tc [PredType]
tys
| TyCon -> Bool
isFamilyTyCon TyCon
tc
= 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 (forall a. Outputable a => a -> SDoc
ppr PredType
pred)))
| Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
= ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go_cls ClassSet
so_far Class
cls [PredType]
tys
| Bool
otherwise
= forall a. Maybe a
Nothing
go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls :: ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go_cls ClassSet
so_far Class
cls [PredType]
tys
| Class
cls forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` ClassSet
so_far
= forall a. a -> Maybe a
Just (Bool
True, String -> SDoc
text String
"one of whose superclasses is" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Class
cls))
| Class -> Bool
isCTupleClass Class
cls
= ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go ClassSet
so_far Class
cls [PredType]
tys
| Bool
otherwise
= do { (Bool
b,SDoc
err) <- ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go (ClassSet
so_far forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`addOneToUniqSet` Class
cls) Class
cls [PredType]
tys
; 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 (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 forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env' Name
name of
Just [Role]
roles -> [Role]
roles
Maybe [Role]
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"inferRoles" (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 = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList forall a. NameEnv a
emptyNameEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
.
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, forall a b. (a -> b) -> [a] -> [b]
map (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 = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initialRoleEnv1" (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 = forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> ArgFlag
tyConBinderArgFlag [TyConBinder]
bndrs
num_exps :: Int
num_exps = forall a. (a -> Bool) -> [a] -> Int
count ArgFlag -> Bool
isVisibleArgFlag [ArgFlag]
argflags
role_annots :: [Maybe Role]
role_annots
= case RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl (GhcPass 'Renamed))
lookupRoleAnnot RoleAnnotEnv
annots_env Name
name of
Just (L SrcSpanAnnA
_ (RoleAnnotDecl XCRoleAnnotDecl (GhcPass 'Renamed)
_ LIdP (GhcPass 'Renamed)
_ [XRec (GhcPass 'Renamed) (Maybe Role)]
annots))
| [XRec (GhcPass 'Renamed) (Maybe Role)]
annots forall a. [a] -> Int -> Bool
`lengthIs` Int
num_exps -> forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [XRec (GhcPass 'Renamed) (Maybe Role)]
annots
Maybe (LRoleAnnotDecl (GhcPass 'Renamed))
_ -> forall a. Int -> a -> [a]
replicate Int
num_exps 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 forall a. Maybe a -> a -> a
`orElse` Role
default_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 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]
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initialRoleEnv1 (2)"
([SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr TyCon
tc, 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 forall a b. (a -> b) -> a -> b
$ 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
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Role
Nominal) [Role]
old_roles) forall a b. (a -> b) -> a -> b
$
forall a. TyCon -> RoleM a -> RoleM a
irTcTyVars TyCon
tc forall a b. (a -> b) -> a -> b
$
do { 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)
; forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc) Class -> RoleM ()
irClass
; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DataCon -> RoleM ()
irDataCon (AlgTyConRhs -> [DataCon]
visibleDataCons forall a b. (a -> b) -> a -> b
$ TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc) }}
| Just PredType
ty <- TyCon -> Maybe PredType
synTyConRhs_maybe TyCon
tc
= forall a. TyCon -> RoleM a -> RoleM a
irTcTyVars TyCon
tc forall a b. (a -> b) -> a -> b
$
VarSet -> PredType -> RoleM ()
irType VarSet
emptyVarSet PredType
ty
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
irClass :: Class -> RoleM ()
irClass :: Class -> RoleM ()
irClass Class
cls
= 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
= 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` VarSet
cls_tv_set) forall a b. (a -> b) -> a -> b
$ TyCon -> [Id]
tyConTyVars TyCon
at_tc
irDataCon :: DataCon -> RoleM ()
irDataCon :: DataCon -> RoleM ()
irDataCon DataCon
datacon
= forall a. [Id] -> RoleM a -> RoleM a
setRoleInferenceVars [Id]
univ_tvs forall a b. (a -> b) -> a -> b
$
forall a. [Id] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [Id]
ex_tvs forall a b. (a -> b) -> a -> b
$ \ VarSet
ex_var_set ->
do 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 forall a. [a] -> [a] -> [a]
++ [PredType]
theta forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled PredType]
arg_tys)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> PredType -> RoleM ()
markNominal VarSet
ex_var_set) (forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
tyVarKind [Id]
ex_tvs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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) = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
lcls) 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 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
; 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
arg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
res
go VarSet
_ (LitTy {}) = 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
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go_app :: VarSet -> Role -> PredType -> RoleM ()
go_app VarSet
_ Role
Phantom PredType
_ = 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
= forall a. Name -> RoleM a -> RoleM a
setRoleInferenceTc (TyCon -> Name
tyConName TyCon
tc) 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)
; forall a. Id -> RoleM a -> RoleM a
addRoleInferenceVar Id
tv 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 forall a b. (a -> b) -> a -> b
$ PredType -> FV
get_ty_vars PredType
ty) in
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) = 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
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Role]
roles forall a. [a] -> [a] -> [a]
++ 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 forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
env (TyCon -> Name
tyConName TyCon
tc) of
Just [Role]
roles -> forall (m :: * -> *) a. Monad m => a -> m a
return [Role]
roles
Maybe [Role]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarPositions
var_ns Id
tv of
Maybe Int
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"updateRole" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> 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 -> 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 = forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM 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
(<*>) = 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 = forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_info VarPositions
vps Int
nvps RoleInferenceState
state ->
let (a
a', RoleInferenceState
state') = 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
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 }
= forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM ()
thing forall a. Maybe a
Nothing forall a. VarEnv a
emptyVarEnv Int
0 RoleInferenceState
state
state :: RoleInferenceState
state = 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 = forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM 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 )
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing (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
= forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
vps Int
nvps RoleInferenceState
state ->
ASSERT( isJust m_name )
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name (forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarPositions
vps Id
tv Int
nvps) (Int
nvpsforall 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
= forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_vps Int
_nvps RoleInferenceState
state ->
ASSERT( isJust m_name )
forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name (forall a. [(Id, a)] -> VarEnv a
mkVarEnv (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
tvs [Int
0..])) (forall a. String -> a
panic String
"setRoleInferenceVars")
RoleInferenceState
state
getRoleEnv :: RoleM RoleEnv
getRoleEnv :: RoleM RoleEnv
getRoleEnv = forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM 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 = forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM 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 = forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_ Int
_ RoleInferenceState
state ->
case Maybe Name
m_name of
Maybe Name
Nothing -> 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
= forall a.
(Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState))
-> RoleM a
RM 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 forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env Name
name of
Maybe [Role]
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"updateRoleEnv" (forall a. Outputable a => a -> SDoc
ppr Name
name)
Just [Role]
roles -> let ([Role]
before, Role
old_role : [Role]
after) = 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 forall a. [a] -> [a] -> [a]
++ Role
role forall a. a -> [a] -> [a]
: [Role]
after
role_env' :: RoleEnv
role_env' = forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv RoleEnv
role_env Name
name [Role]
roles' in
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
= forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tyclss forall a b. (a -> b) -> a -> b
$
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
implicit_things forall a b. (a -> b) -> a -> b
$
forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
def_meth_ids forall a b. (a -> b) -> a -> b
$
do { String -> SDoc -> TcM ()
traceTc String
"tcAddTyCons" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ String -> SDoc
text String
"tycons" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss
, String -> SDoc
text String
"implicits" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyThing]
implicit_things ]
; [(Id, LHsBind (GhcPass 'Renamed))] -> TcM TcGblEnv
tcRecSelBinds ([TyCon] -> [(Id, LHsBind (GhcPass 'Renamed))]
mkRecSelBinds [TyCon]
tyclss) }
where
implicit_things :: [TyThing]
implicit_things = 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 (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 = forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders forall a b. (a -> b) -> a -> b
$ [TyConBinder] -> [InvisTVBinder]
tyConInvisTVBinders [TyConBinder]
cls_bndrs
tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds :: [(Id, LHsBind (GhcPass 'Renamed))] -> TcM TcGblEnv
tcRecSelBinds [(Id, LHsBind (GhcPass 'Renamed))]
sel_bind_prs
= forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
sel_id | (L SrcSpanAnnA
_ (IdSig XIdSig (GhcPass 'Renamed)
_ Id
sel_id)) <- [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs] forall a b. (a -> b) -> a -> b
$
do { ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
rec_sel_binds, TcGblEnv
tcg_env) <- forall a. TcRn a -> TcRn a
discardWarnings forall a b. (a -> b) -> a -> b
$
forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ImpredicativeTypes forall a b. (a -> b) -> a -> b
$
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag,
Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))))]
binds [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
rec_sel_binds) }
where
sigs :: [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs = [ forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall pass. XIdSig pass -> Id -> Sig pass
IdSig NoExtField
noExtField Id
sel_id)
| (Id
sel_id, GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_) <- [(Id, LHsBind (GhcPass 'Renamed))]
sel_bind_prs
, let loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
sel_id ]
binds :: [(RecFlag,
Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))))]
binds = [(RecFlag
NonRecursive, forall a. a -> Bag a
unitBag GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind) | (Id
_, GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind) <- [(Id, LHsBind (GhcPass 'Renamed))]
sel_bind_prs]
mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
mkRecSelBinds :: [TyCon] -> [(Id, LHsBind (GhcPass 'Renamed))]
mkRecSelBinds [TyCon]
tycons
= forall a b. (a -> b) -> [a] -> [b]
map (TyCon, FieldLabel) -> (Id, LHsBind (GhcPass 'Renamed))
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 (GhcPass 'Renamed))
mkRecSelBind (TyCon
tycon, FieldLabel
fl)
= [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (Id, LHsBind (GhcPass 'Renamed))
mkOneRecordSelector [ConLike]
all_cons (TyCon -> RecSelParent
RecSelData TyCon
tycon) FieldLabel
fl
FieldSelectors
FieldSelectors
where
all_cons :: [ConLike]
all_cons = 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
-> (Id, LHsBind (GhcPass 'Renamed))
mkOneRecordSelector [ConLike]
all_cons RecSelParent
idDetails FieldLabel
fl FieldSelectors
has_sel
= (Id
sel_id, forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
sel_bind)
where
loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
sel_name
loc' :: SrcSpanAnnA
loc' = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
locn :: SrcSpanAnnN
locn = 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 :: Id
sel_id = IdDetails -> Name -> PredType -> Id
mkExportedLocalId IdDetails
rec_details Name
sel_name PredType
sel_ty
rec_details :: IdDetails
rec_details = 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 :: [InvisTVBinder]
data_tvbs = forall a. (a -> Bool) -> [a] -> [a]
filter (\InvisTVBinder
tvb -> forall tv argf. VarBndr tv argf -> tv
binderVar InvisTVBinder
tvb Id -> VarSet -> Bool
`elemVarSet` VarSet
data_tv_set) forall a b. (a -> b) -> a -> b
$
ConLike -> [InvisTVBinder]
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)
Bool -> Bool -> Bool
|| FieldSelectors
has_sel forall a. Eq a => a -> a -> Bool
== FieldSelectors
NoFieldSelectors
sel_ty :: PredType
sel_ty | Bool
is_naughty = PredType
unitTy
| Bool
otherwise = [TyCoVarBinder] -> PredType -> PredType
mkForAllTys (forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders [InvisTVBinder]
data_tvbs) forall a b. (a -> b) -> a -> b
$
[PredType] -> PredType -> PredType
mkPhiTy (ConLike -> [PredType]
conLikeStupidTheta ConLike
con1) forall a b. (a -> b) -> a -> b
$
[PredType] -> PredType -> PredType
mkPhiTy [PredType]
req_theta forall a b. (a -> b) -> a -> b
$
PredType -> PredType -> PredType
mkVisFunTyMany PredType
data_ty forall a b. (a -> b) -> a -> b
$
PredType
field_ty
sel_bind :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
sel_bind = Origin
-> GenLocated SrcSpanAnnN Name
-> [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
mkTopFunBind Origin
Generated GenLocated SrcSpanAnnN Name
sel_lname [GenLocated
(Anno
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
alts
where
alts :: [GenLocated
(Anno
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
alts | Bool
is_naughty = [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpanAnnN Name
sel_lname)
[] LocatedA (HsExpr (GhcPass 'Renamed))
unit_rhs]
| Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map ConLike
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
mk_match [ConLike]
cons_w_field forall a. [a] -> [a] -> [a]
++ [GenLocated
(Anno
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
deflt
mk_match :: ConLike
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
mk_match ConLike
con = forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpanAnnN Name
sel_lname)
[forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (ConLike -> Pat (GhcPass 'Renamed)
mk_sel_pat ConLike
con)]
(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn Name
field_var)))
mk_sel_pat :: ConLike -> Pat (GhcPass 'Renamed)
mk_sel_pat ConLike
con = forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat NoExtField
NoExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn (forall a. NamedThing a => a -> Name
getName ConLike
con)) (forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon HsRecFields
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
rec_fields)
rec_fields :: HsRecFields
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
rec_fields = HsRecFields { rec_flds :: [LHsRecField
(GhcPass 'Renamed)
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))]
rec_flds = [LocatedAn
AnnListItem
(HsRecField'
(FieldOcc (GhcPass 'Renamed))
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
rec_field], rec_dotdot :: Maybe (Located Int)
rec_dotdot = forall a. Maybe a
Nothing }
rec_field :: LocatedAn
AnnListItem
(HsRecField'
(FieldOcc (GhcPass 'Renamed))
(GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
rec_field = forall a an. a -> LocatedAn an a
noLocA (HsRecField
{ hsRecFieldAnn :: XHsRecField (FieldOcc (GhcPass 'Renamed))
hsRecFieldAnn = forall a. EpAnn a
noAnn
, hsRecFieldLbl :: Located (FieldOcc (GhcPass 'Renamed))
hsRecFieldLbl
= forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc Name
sel_name
(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn forall a b. (a -> b) -> a -> b
$ FieldLabelString -> RdrName
mkVarUnqual FieldLabelString
lbl))
, hsRecFieldArg :: GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
hsRecFieldArg
= forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn Name
field_var))
, hsRecPun :: Bool
hsRecPun = Bool
False })
sel_lname :: GenLocated SrcSpanAnnN Name
sel_lname = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn Name
sel_name
field_var :: Name
field_var = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique Int
1) (forall a. NamedThing a => a -> OccName
getOccName Name
sel_name) SrcSpan
loc
deflt :: [GenLocated
(Anno
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
(Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
deflt | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConLike -> Bool
dealt_with [ConLike]
all_cons = []
| Bool
otherwise = [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch forall p. HsMatchContext p
CaseAlt
[forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XWildPat p -> Pat p
WildPat NoExtField
noExtField)]
(forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField
(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn (forall a. NamedThing a => a -> Name
getName Id
rEC_SEL_ERROR_ID))))
(forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments HsLit (GhcPass 'Renamed)
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 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 (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 'Renamed)
unit_rhs = forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsTupleExpr [] NoExtField
noExtField
msg_lit :: HsLit (GhcPass 'Renamed)
msg_lit = forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
NoSourceText (FieldLabelString -> ByteString
bytesFS FieldLabelString
lbl)