{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.Tc.Utils.Env(
TyThing(..), TcTyThing(..), TcId,
InstInfo(..), iDFunId, pprInstInfoDetails,
simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
tcExtendGlobalEnv, tcExtendTyConEnv,
tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
tcExtendGlobalValEnv, tcTyThBinders,
tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
tcLookupTyCon, tcLookupClass,
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
tcLookupRecSelParent,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
lookupGlobal, lookupGlobal_maybe,
addTypecheckedBinds,
failIllegalTyCon, failIllegalTyVal,
tcExtendKindEnv, tcExtendKindEnvList,
tcExtendTyVarEnv, tcExtendNameTyVarEnv,
tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcExtendBinderStack, tcExtendLocalTypeEnv,
isTypeClosedLetBndr,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
tcLookupTcTyCon,
tcLookupLcl_maybe,
getInLocalScope,
wrongThingErr, pprBinders,
tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders, tcAddKindSigPlaceholders,
getTypeSigNames,
tcExtendRecEnv,
tcLookupInstance, tcGetInstEnvs,
tcExtendRules,
tcGetDefaultTys,
StageCheckReason(..),
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, isBrackStage,
newDFunName,
newFamInstTyConName, newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
mkWrapperName,
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.DynFlags
import GHC.Builtin.Names
import GHC.Builtin.Types
import GHC.Runtime.Context
import GHC.Hs
import GHC.Iface.Env
import GHC.Iface.Load
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.TcType
import {-# SOURCE #-} GHC.Tc.Utils.TcMType ( tcCheckUsage )
import GHC.Tc.Types.LclEnv
import GHC.Core.InstEnv
import GHC.Core.DataCon ( DataCon, dataConTyCon, flSelector )
import GHC.Core.PatSyn ( PatSyn )
import GHC.Core.ConLike
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Core.Coercion.Axiom
import GHC.Core.Class
import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Unit.External
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding
import GHC.Utils.Misc ( HasDebugCallStack )
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Data.Maybe( MaybeErr(..), orElse )
import GHC.Types.SrcLoc
import GHC.Types.Basic hiding( SuccessFlag(..) )
import GHC.Types.TypeEnv
import GHC.Types.SourceFile
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.Name.Env
import GHC.Types.DefaultEnv ( DefaultEnv, ClassDefaults(..),
defaultEnv, emptyDefaultEnv, lookupDefaultEnv, unitDefaultEnv )
import GHC.Types.Id
import GHC.Types.Id.Info ( RecSelParent(..) )
import GHC.Types.Name.Reader
import GHC.Types.TyThing
import GHC.Types.Unique.Set ( nonDetEltsUniqSet )
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Data.List ( intercalate )
import Control.Monad
import GHC.Iface.Errors.Types
import GHC.Types.Error
import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
lookupGlobal :: HscEnv -> Name -> IO TyThing
lookupGlobal :: HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
name
= do {
mb_thing <- HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
; case mb_thing of
Succeeded TyThing
thing -> TyThing -> IO TyThing
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
Failed Either Name IfaceMessage
err ->
let msg :: SDoc
msg = case Either Name IfaceMessage
err of
Left Name
name -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Could not find local name:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
Right IfaceMessage
err -> IfaceMessage -> SDoc
forall e. Diagnostic e => e -> SDoc
pprDiagnostic IfaceMessage
err
in String -> SDoc -> IO TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupGlobal" SDoc
msg
}
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing)
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr (Either Name IfaceMessage) TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
= do {
let mod :: Module
mod = InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
tcg_semantic_mod :: Module
tcg_semantic_mod = Maybe HomeUnit -> Module -> Module
homeModuleInstantiation Maybe HomeUnit
mhome_unit Module
mod
; if Module -> Name -> Bool
nameIsLocalOrFrom Module
tcg_semantic_mod Name
name
then MaybeErr (Either Name IfaceMessage) TyThing
-> IO (MaybeErr (Either Name IfaceMessage) TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeErr (Either Name IfaceMessage) TyThing
-> IO (MaybeErr (Either Name IfaceMessage) TyThing))
-> MaybeErr (Either Name IfaceMessage) TyThing
-> IO (MaybeErr (Either Name IfaceMessage) TyThing)
forall a b. (a -> b) -> a -> b
$ Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing
forall err val. err -> MaybeErr err val
Failed (Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing)
-> Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing
forall a b. (a -> b) -> a -> b
$ Name -> Either Name IfaceMessage
forall a b. a -> Either a b
Left Name
name
else do
res <- HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
return $ case res of
Succeeded TyThing
ok -> TyThing -> MaybeErr (Either Name IfaceMessage) TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
ok
Failed IfaceMessage
err -> Either Name IfaceMessage
-> MaybeErr (Either Name IfaceMessage) TyThing
forall err val. err -> MaybeErr err val
Failed (IfaceMessage -> Either Name IfaceMessage
forall a b. b -> Either a b
Right IfaceMessage
err)
}
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
= do { mb_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name
; case mb_thing of
Just TyThing
thing -> MaybeErr IfaceMessage TyThing -> IO (MaybeErr IfaceMessage TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> MaybeErr IfaceMessage TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
thing)
Maybe TyThing
Nothing -> HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
importDecl_maybe HscEnv
hsc_env Name
name
}
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr IfaceMessage TyThing)
importDecl_maybe HscEnv
hsc_env Name
name
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
name
= do { Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyThing -> Bool
needWiredInHomeIface TyThing
thing)
(HscEnv -> IfG () -> IO ()
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Name -> IfG ()
forall lcl. Name -> IfM lcl ()
loadWiredInHomeIface Name
name))
; MaybeErr IfaceMessage TyThing -> IO (MaybeErr IfaceMessage TyThing)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TyThing -> MaybeErr IfaceMessage TyThing
forall err val. val -> MaybeErr err val
Succeeded TyThing
thing) }
| Bool
otherwise
= HscEnv
-> IfG (MaybeErr IfaceMessage TyThing)
-> IO (MaybeErr IfaceMessage TyThing)
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Name -> IfG (MaybeErr IfaceMessage TyThing)
forall lcl. Name -> IfM lcl (MaybeErr IfaceMessage TyThing)
importDecl Name
name)
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
addTypecheckedBinds TcGblEnv
tcg_env [LHsBinds GhcTc]
binds
| HscSource -> Bool
isHsBootOrSig (TcGblEnv -> HscSource
tcg_src TcGblEnv
tcg_env) = TcGblEnv
tcg_env
| Bool
otherwise = TcGblEnv
tcg_env { tcg_binds = foldr (++)
(tcg_binds tcg_env)
binds }
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
tcLookupLocatedGlobal LocatedA Name
name
= (Name -> TcM TyThing) -> LocatedA Name -> TcM TyThing
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM TyThing
tcLookupGlobal LocatedA Name
name
tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal Name
name
= do {
env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; case lookupNameEnv (tcg_type_env env) name of {
Just TyThing
thing -> TyThing -> TcM TyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing ;
Maybe TyThing
Nothing ->
if Module -> Name -> Bool
nameIsLocalOrFrom (TcGblEnv -> Module
tcg_semantic_mod TcGblEnv
env) Name
name
then Name -> TcM TyThing
notFound Name
name
else
do { mb_thing <- Name -> TcM (MaybeErr IfaceMessage TyThing)
tcLookupImported_maybe Name
name
; case mb_thing of
Succeeded TyThing
thing -> TyThing -> TcM TyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
Failed IfaceMessage
msg -> TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (IfaceMessage -> TcRnMessage
TcRnInterfaceError IfaceMessage
msg)
}}}
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly Name
name
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; return $ case lookupNameEnv (tcg_type_env env) name of
Just TyThing
thing -> TyThing
thing
Maybe TyThing
Nothing -> String -> SDoc -> TyThing
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupGlobalOnly" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) }
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon Name
name = do
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case thing of
AConLike (RealDataCon DataCon
con) -> DataCon -> TcM DataCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
con
TyThing
_ -> WrongThingSort -> TcTyThing -> Name -> TcM DataCon
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingDataCon (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn Name
name = do
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case thing of
AConLike (PatSynCon PatSyn
ps) -> PatSyn -> TcM PatSyn
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return PatSyn
ps
TyThing
_ -> WrongThingSort -> TcTyThing -> Name -> TcM PatSyn
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingPatSyn (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike Name
name = do
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case thing of
AConLike ConLike
cl -> ConLike -> TcM ConLike
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ConLike
cl
ATyCon {} -> WhatLooking -> Name -> TcM ConLike
forall a. WhatLooking -> Name -> TcM a
failIllegalTyCon WhatLooking
WL_Constructor Name
name
TyThing
_ -> WrongThingSort -> TcTyThing -> Name -> TcM ConLike
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingConLike (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
tcLookupRecSelParent (RnRecUpdParent { rnRecUpdCons :: HsRecUpdParent GhcRn -> UniqSet ConLikeName
rnRecUpdCons = UniqSet ConLikeName
cons })
= case ConLikeName
any_con of
PatSynName Name
ps ->
PatSyn -> RecSelParent
RecSelPatSyn (PatSyn -> RecSelParent) -> TcM PatSyn -> TcM RecSelParent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM PatSyn
tcLookupPatSyn Name
ps
DataConName Name
dc ->
TyCon -> RecSelParent
RecSelData (TyCon -> RecSelParent)
-> (DataCon -> TyCon) -> DataCon -> RecSelParent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> TyCon
dataConTyCon (DataCon -> RecSelParent) -> TcM DataCon -> TcM RecSelParent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM DataCon
tcLookupDataCon Name
dc
where
any_con :: ConLikeName
any_con = [ConLikeName] -> ConLikeName
forall a. HasCallStack => [a] -> a
head ([ConLikeName] -> ConLikeName) -> [ConLikeName] -> ConLikeName
forall a b. (a -> b) -> a -> b
$ UniqSet ConLikeName -> [ConLikeName]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet UniqSet ConLikeName
cons
tcLookupClass :: Name -> TcM Class
tcLookupClass :: Name -> TcM Class
tcLookupClass Name
name = do
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case thing of
ATyCon TyCon
tc | Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> Class -> TcM Class
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Class
cls
TyThing
_ -> WrongThingSort -> TcTyThing -> Name -> TcM Class
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingClass (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon Name
name = do
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case thing of
ATyCon TyCon
tc -> TyCon -> TcM TyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
TyThing
_ -> WrongThingSort -> TcTyThing -> Name -> TcM TyCon
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingTyCon (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom Name
name = do
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case thing of
ACoAxiom CoAxiom Branched
ax -> CoAxiom Branched -> TcM (CoAxiom Branched)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return CoAxiom Branched
ax
TyThing
_ -> WrongThingSort -> TcTyThing -> Name -> TcM (CoAxiom Branched)
forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
WrongThingAxiom (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = (Name -> TcM Id) -> LocatedA Name -> TcM Id
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM Id
tcLookupId
tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass = (Name -> TcM Class) -> LocatedA Name -> TcM Class
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM Class
tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon = (Name -> TcM TyCon) -> LocatedN Name -> TcM TyCon
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM TyCon
tcLookupTyCon
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance Class
cls [Type]
tys
= do { instEnv <- TcM InstEnvs
tcGetInstEnvs
; let inst = InstEnvs
-> Class
-> [Type]
-> Either LookupInstanceErrReason (ClsInst, [Type])
lookupUniqueInstEnv InstEnvs
instEnv Class
cls [Type]
tys Either LookupInstanceErrReason (ClsInst, [Type])
-> ((ClsInst, [Type]) -> Either LookupInstanceErrReason ClsInst)
-> Either LookupInstanceErrReason ClsInst
forall a b.
Either LookupInstanceErrReason a
-> (a -> Either LookupInstanceErrReason b)
-> Either LookupInstanceErrReason b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (ClsInst
inst, [Type]
tys) ->
if [Type] -> Bool
uniqueTyVars [Type]
tys then ClsInst -> Either LookupInstanceErrReason ClsInst
forall a b. b -> Either a b
Right ClsInst
inst else LookupInstanceErrReason -> Either LookupInstanceErrReason ClsInst
forall a b. a -> Either a b
Left LookupInstanceErrReason
LookupInstErrNotExact
; case inst of
Right ClsInst
i -> ClsInst -> TcM ClsInst
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInst
i
Left LookupInstanceErrReason
err -> TcRnMessage -> TcM ClsInst
forall a. TcRnMessage -> TcM a
failWithTc (Class -> [Type] -> LookupInstanceErrReason -> TcRnMessage
TcRnLookupInstance Class
cls [Type]
tys LookupInstanceErrReason
err)
}
where
uniqueTyVars :: [Type] -> Bool
uniqueTyVars [Type]
tys = (Type -> Bool) -> [Type] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVarTy [Type]
tys
Bool -> Bool -> Bool
&& [Id] -> Bool
forall a. Eq a => [a] -> Bool
hasNoDups ((Type -> Id) -> [Type] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map HasDebugCallStack => Type -> Id
Type -> Id
getTyVar [Type]
tys)
tcGetInstEnvs :: TcM InstEnvs
tcGetInstEnvs :: TcM InstEnvs
tcGetInstEnvs = do { eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; env <- getGblEnv
; return (InstEnvs { ie_global = eps_inst_env eps
, ie_local = tcg_inst_env env
, ie_visible = tcVisibleOrphanMods env }) }
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing :: Name -> TcM TyThing
lookupThing = Name -> TcM TyThing
tcLookupGlobal
failIllegalTyCon :: WhatLooking -> Name -> TcM a
failIllegalTyVal :: Name -> TcM a
(WhatLooking -> Name -> TcM a
failIllegalTyCon, Name -> TcM a
failIllegalTyVal) = (WhatLooking -> Name -> TcM a
forall a. WhatLooking -> Name -> TcM a
fail_tycon, Name -> TcM a
forall {b}. Name -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_tyvar)
where
fail_tycon :: WhatLooking -> Name -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_tycon WhatLooking
what_looking Name
tc_nm = do
gre <- TcRn GlobalRdrEnv
getGlobalRdrEnv
let mb_gre = GlobalRdrEnv -> Name -> Maybe (GlobalRdrEltX GREInfo)
forall info.
Outputable info =>
GlobalRdrEnvX info -> Name -> Maybe (GlobalRdrEltX info)
lookupGRE_Name GlobalRdrEnv
gre Name
tc_nm
pprov = case Maybe (GlobalRdrEltX GREInfo)
mb_gre of
Just GlobalRdrEltX GREInfo
gre -> ThLevel -> SDoc -> SDoc
nest ThLevel
2 (GlobalRdrEltX GREInfo -> SDoc
forall info. GlobalRdrEltX info -> SDoc
pprNameProvenance GlobalRdrEltX GREInfo
gre)
Maybe (GlobalRdrEltX GREInfo)
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
err = case GlobalRdrEltX GREInfo -> GREInfo
greInfo (GlobalRdrEltX GREInfo -> GREInfo)
-> Maybe (GlobalRdrEltX GREInfo) -> Maybe GREInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (GlobalRdrEltX GREInfo)
mb_gre of
Just (IAmTyCon TyConFlavour Name
ClassFlavour) -> TermLevelUseErr
ClassTE
Maybe GREInfo
_ -> TermLevelUseErr
TyConTE
fail_with_msg what_looking dataName tc_nm pprov err
fail_tyvar :: Name -> IOEnv (Env TcGblEnv TcLclEnv) b
fail_tyvar Name
nm =
let pprov :: SDoc
pprov = ThLevel -> SDoc -> SDoc
nest ThLevel
2 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"bound at" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SrcLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Name -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
getSrcLoc Name
nm))
in WhatLooking
-> NameSpace
-> Name
-> SDoc
-> TermLevelUseErr
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall {b}.
WhatLooking
-> NameSpace
-> Name
-> SDoc
-> TermLevelUseErr
-> IOEnv (Env TcGblEnv TcLclEnv) b
fail_with_msg WhatLooking
WL_Anything NameSpace
varName Name
nm SDoc
pprov TermLevelUseErr
TyVarTE
fail_with_msg :: WhatLooking
-> NameSpace
-> Name
-> SDoc
-> TermLevelUseErr
-> IOEnv (Env TcGblEnv TcLclEnv) b
fail_with_msg WhatLooking
what_looking NameSpace
whatName Name
nm SDoc
pprov TermLevelUseErr
err = do
(import_errs, hints) <- WhatLooking
-> NameSpace
-> Name
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
forall {name}.
HasOccName name =>
WhatLooking
-> NameSpace
-> name
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions WhatLooking
what_looking NameSpace
whatName Name
nm
unit_state <- hsc_units <$> getTopEnv
let
hint_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (GhcHint -> SDoc) -> [GhcHint] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map GhcHint -> SDoc
forall a. Outputable a => a -> SDoc
ppr [GhcHint]
hints
import_err_msg = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ (ImportError -> SDoc) -> [ImportError] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ImportError -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ImportError]
import_errs
info = ErrInfo { errInfoContext :: SDoc
errInfoContext = SDoc
pprov, errInfoSupplementary :: SDoc
errInfoSupplementary = SDoc
import_err_msg SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
hint_msg }
failWithTc $ TcRnMessageWithInfo unit_state (
mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))
get_suggestions :: WhatLooking
-> NameSpace
-> name
-> IOEnv (Env TcGblEnv TcLclEnv) ([ImportError], [GhcHint])
get_suggestions WhatLooking
what_looking NameSpace
ns name
nm = do
required_type_arguments <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.RequiredTypeArguments
if required_type_arguments && isVarNameSpace ns
then return ([], [])
else do
let occ = NameSpace -> FastString -> OccName
mkOccNameFS NameSpace
ns (OccName -> FastString
occNameFS (name -> OccName
forall name. HasOccName name => name -> OccName
occName name
nm))
lcl_env <- getLocalRdrEnv
unknownNameSuggestions lcl_env what_looking (mkRdrUnqual occ)
setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv :: TcGblEnv -> NameEnv TyThing -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env NameEnv TyThing
new_type_env
= do {
; case KnotVars (IORef (NameEnv TyThing))
-> Module -> Maybe (IORef (NameEnv TyThing))
forall a. KnotVars a -> Module -> Maybe a
lookupKnotVars (TcGblEnv -> KnotVars (IORef (NameEnv TyThing))
tcg_type_env_var TcGblEnv
tcg_env) (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env) of
Just IORef (NameEnv TyThing)
tcg_env_var -> IORef (NameEnv TyThing)
-> NameEnv TyThing -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar IORef (NameEnv TyThing)
tcg_env_var NameEnv TyThing
new_type_env
Maybe (IORef (NameEnv TyThing))
Nothing -> () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; TcGblEnv -> TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_type_env = new_type_env }) }
tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit :: forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
things TcM r
thing_inside
= do { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let ge' = NameEnv TyThing -> [TyThing] -> NameEnv TyThing
extendTypeEnvList (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
tcg_env) [TyThing]
things
; tcg_env' <- setGlobalTypeEnv tcg_env ge'
; setGblEnv tcg_env' thing_inside }
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv :: forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing]
things TcM r
thing_inside
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let env' = TcGblEnv
env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,
tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit things thing_inside
}
tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv :: forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tycons TcM r
thing_inside
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let env' = TcGblEnv
env { tcg_tcs = tycons ++ tcg_tcs env }
; setGblEnv env' $
tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside
}
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders :: [TyThing] -> TcM ThBindEnv
tcTyThBinders [TyThing]
implicit_things = do
stage <- TcM ThStage
getStage
let th_lvl = ThStage -> ThLevel
thLevel ThStage
stage
th_bndrs = [(Name, (TopLevelFlag, ThLevel))] -> ThBindEnv
forall a. [(Name, a)] -> NameEnv a
mkNameEnv
[ ( Name
n , (TopLevelFlag
TopLevel, ThLevel
th_lvl) ) | Name
n <- [Name]
names ]
return th_bndrs
where
names :: [Name]
names = (TyThing -> [Name]) -> [TyThing] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TyThing -> [Name]
get_names [TyThing]
implicit_things
get_names :: TyThing -> [Name]
get_names (AConLike ConLike
acl) =
ConLike -> Name
conLikeName ConLike
acl Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector (ConLike -> [FieldLabel]
conLikeFieldLabels ConLike
acl)
get_names (AnId Id
i) = [Id -> Name
idName Id
i]
get_names TyThing
_ = []
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
ids TcM a
thing_inside
= [TyThing] -> TcM a -> TcM a
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [Id -> TyThing
AnId Id
id | Id
id <- [Id]
ids] TcM a
thing_inside
tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
tcExtendRecEnv :: forall r. [(Name, TyThing)] -> TcM r -> TcM r
tcExtendRecEnv [(Name, TyThing)]
gbl_stuff TcM r
thing_inside
= do { tcg_env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let ge' = NameEnv TyThing -> [(Name, TyThing)] -> NameEnv TyThing
forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> NameEnv TyThing
tcg_type_env TcGblEnv
tcg_env) [(Name, TyThing)]
gbl_stuff
tcg_env' = TcGblEnv
tcg_env { tcg_type_env = ge' }
; setGblEnv tcg_env' thing_inside }
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated = (Name -> TcM TcTyThing) -> LocatedA Name -> TcM TcTyThing
forall t a b. HasLoc t => (a -> TcM b) -> GenLocated t a -> TcM b
addLocM Name -> TcM TcTyThing
tcLookup
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe Name
name
= do { local_env <- TcM TcTypeEnv
getLclTypeEnv
; return (lookupNameEnv local_env name) }
tcLookup :: Name -> TcM TcTyThing
tcLookup :: Name -> TcM TcTyThing
tcLookup Name
name = do
local_env <- TcM TcTypeEnv
getLclTypeEnv
case lookupNameEnv local_env name of
Just TcTyThing
thing -> TcTyThing -> TcM TcTyThing
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcTyThing
thing
Maybe TcTyThing
Nothing -> TyThing -> TcTyThing
AGlobal (TyThing -> TcTyThing) -> TcM TyThing -> TcM TcTyThing
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TcM TyThing
tcLookupGlobal Name
name
tcLookupTyVar :: Name -> TcM TcTyVar
tcLookupTyVar :: Name -> TcM Id
tcLookupTyVar Name
name
= do { thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case thing of
ATyVar Name
_ Id
tv -> Id -> TcM Id
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
tv
TcTyThing
_ -> String -> SDoc -> TcM Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupTyVar" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) }
tcLookupId :: Name -> TcM Id
tcLookupId :: Name -> TcM Id
tcLookupId Name
name = do
thing <- Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
case thing of
Just Id
id -> Id -> TcM Id
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
id
Maybe Id
_ -> String -> SDoc -> TcM Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupId" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
= do { thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case thing of
ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id} -> Maybe Id -> TcM (Maybe Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> TcM (Maybe Id)) -> Maybe Id -> TcM (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
forall a. a -> Maybe a
Just Id
id
AGlobal (AnId Id
id) -> Maybe Id -> TcM (Maybe Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Id -> TcM (Maybe Id)) -> Maybe Id -> TcM (Maybe Id)
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Id
forall a. a -> Maybe a
Just Id
id
TcTyThing
_ -> Maybe Id -> TcM (Maybe Id)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Id
forall a. Maybe a
Nothing }
tcLookupLocalIds :: [Name] -> TcM [TcId]
tcLookupLocalIds :: [Name] -> TcM [Id]
tcLookupLocalIds [Name]
ns
= do { env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; return (map (lookup (getLclEnvTypeEnv env)) ns) }
where
lookup :: TcTypeEnv -> Name -> Id
lookup TcTypeEnv
lenv Name
name
= case TcTypeEnv -> Name -> Maybe TcTyThing
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
lenv Name
name of
Just (ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id }) -> Id
id
Maybe TcTyThing
_ -> String -> SDoc -> Id
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupLocalIds" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TyCon
tcLookupTcTyCon Name
name = do
thing <- Name -> TcM TcTyThing
tcLookup Name
name
case thing of
ATcTyCon TyCon
tc -> TyCon -> TcM TyCon
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
TcTyThing
_ -> String -> SDoc -> TcM TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupTcTyCon" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { lcl_env <- TcM TcTypeEnv
getLclTypeEnv
; return (`elemNameEnv` lcl_env) }
tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList :: forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [(Name, TcTyThing)]
things TcM r
thing_inside
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcExtendKindEnvList" ([(Name, TcTyThing)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TcTyThing)]
things)
; (TcLclCtxt -> TcLclCtxt) -> TcM r -> TcM r
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd_env TcM r
thing_inside }
where
upd_env :: TcLclCtxt -> TcLclCtxt
upd_env TcLclCtxt
env = TcLclCtxt
env { tcl_env = extendNameEnvList (tcl_env env) things }
tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r
tcExtendKindEnv :: forall r. TcTypeEnv -> TcM r -> TcM r
tcExtendKindEnv TcTypeEnv
extra_env TcM r
thing_inside
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcExtendKindEnv" (TcTypeEnv -> SDoc
forall a. Outputable a => a -> SDoc
ppr TcTypeEnv
extra_env)
; (TcLclCtxt -> TcLclCtxt) -> TcM r -> TcM r
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd_env TcM r
thing_inside }
where
upd_env :: TcLclCtxt -> TcLclCtxt
upd_env TcLclCtxt
env = TcLclCtxt
env { tcl_env = tcl_env env `plusNameEnv` extra_env }
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendTyVarEnv [Id]
tvs TcM r
thing_inside
= [(Name, Id)] -> TcM r -> TcM r
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv ([Id] -> [(Name, Id)]
mkTyVarNamePairs [Id]
tvs) TcM r
thing_inside
tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendNameTyVarEnv :: forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendNameTyVarEnv [(Name, Id)]
binds TcM r
thing_inside
= TopLevelFlag -> [(Name, TcTyThing)] -> TcM r -> TcM r
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel [(Name, TcTyThing)]
names (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
[TcBinder] -> TcM r -> TcM r
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcBinder]
tv_binds (TcM r -> TcM r) -> TcM r -> TcM r
forall a b. (a -> b) -> a -> b
$
TcM r
thing_inside
where
tv_binds :: [TcBinder]
tv_binds :: [TcBinder]
tv_binds = [Name -> Id -> TcBinder
TcTvBndr Name
name Id
tv | (Name
name,Id
tv) <- [(Name, Id)]
binds]
names :: [(Name, TcTyThing)]
names = [(Name
name, Name -> Id -> TcTyThing
ATyVar Name
name Id
tv) | (Name
name, Id
tv) <- [(Name, Id)]
binds]
isTypeClosedLetBndr :: Id -> Bool
isTypeClosedLetBndr :: Id -> Bool
isTypeClosedLetBndr = Type -> Bool
noFreeVarsOfType (Type -> Bool) -> (Id -> Type) -> Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> Type
idType
tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a
tcExtendRecIds :: forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendRecIds [(Name, Id)]
pairs TcM a
thing_inside
= TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel
[ (Name
name, ATcId { tct_id :: Id
tct_id = Id
let_id
, tct_info :: IdBindingInfo
tct_info = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
emptyNameSet Bool
False })
| (Name
name, Id
let_id) <- [(Name, Id)]
pairs ] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TcM a
thing_inside
tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a
tcExtendSigIds :: forall a. TopLevelFlag -> [Id] -> TcM a -> TcM a
tcExtendSigIds TopLevelFlag
top_lvl [Id]
sig_ids TcM a
thing_inside
= TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
top_lvl
[ (Id -> Name
idName Id
id, ATcId { tct_id :: Id
tct_id = Id
id
, tct_info :: IdBindingInfo
tct_info = IdBindingInfo
info })
| Id
id <- [Id]
sig_ids
, let closed :: Bool
closed = Id -> Bool
isTypeClosedLetBndr Id
id
info :: IdBindingInfo
info = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
emptyNameSet Bool
closed ]
TcM a
thing_inside
tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed
-> [Scaled TcId] -> TcM a -> TcM a
tcExtendLetEnv :: forall a.
TopLevelFlag
-> TcSigFun -> IsGroupClosed -> [Scaled Id] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn (IsGroupClosed NameEnv RhsNames
fvs Bool
fv_type_closed)
[Scaled Id]
ids TcM a
thing_inside
= [TcBinder] -> TcM a -> TcM a
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
id TopLevelFlag
top_lvl | Scaled Type
_ Id
id <- [Scaled Id]
ids] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
top_lvl
[ (Id -> Name
idName Id
id, ATcId { tct_id :: Id
tct_id = Id
id
, tct_info :: IdBindingInfo
tct_info = Id -> IdBindingInfo
mk_tct_info Id
id })
| Scaled Type
_ Id
id <- [Scaled Id]
ids ] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
(Scaled Name -> TcM a -> TcM a) -> TcM a -> [Scaled Name] -> TcM a
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scaled Name -> TcM a -> TcM a
forall a. Scaled Name -> TcM a -> TcM a
check_usage TcM a
thing_inside [Scaled Name]
scaled_names
where
mk_tct_info :: Id -> IdBindingInfo
mk_tct_info Id
id
| Bool
type_closed Bool -> Bool -> Bool
&& RhsNames -> Bool
isEmptyNameSet RhsNames
rhs_fvs = IdBindingInfo
ClosedLet
| Bool
otherwise = RhsNames -> Bool -> IdBindingInfo
NonClosedLet RhsNames
rhs_fvs Bool
type_closed
where
name :: Name
name = Id -> Name
idName Id
id
rhs_fvs :: RhsNames
rhs_fvs = NameEnv RhsNames -> Name -> Maybe RhsNames
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv RhsNames
fvs Name
name Maybe RhsNames -> RhsNames -> RhsNames
forall a. Maybe a -> a -> a
`orElse` RhsNames
emptyNameSet
type_closed :: Bool
type_closed = Id -> Bool
isTypeClosedLetBndr Id
id Bool -> Bool -> Bool
&&
(Bool
fv_type_closed Bool -> Bool -> Bool
|| TcSigFun -> Name -> Bool
hasCompleteSig TcSigFun
sig_fn Name
name)
scaled_names :: [Scaled Name]
scaled_names = [Type -> Name -> Scaled Name
forall a. Type -> a -> Scaled a
Scaled Type
p (Id -> Name
idName Id
id) | Scaled Type
p Id
id <- [Scaled Id]
ids ]
check_usage :: Scaled Name -> TcM a -> TcM a
check_usage :: forall a. Scaled Name -> TcM a -> TcM a
check_usage (Scaled Type
p Name
id) TcM a
thing_inside = do
Name -> Type -> TcM a -> TcM a
forall a. Name -> Type -> TcM a -> TcM a
tcCheckUsage Name
id Type
p TcM a
thing_inside
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
tcExtendIdEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
ids TcM a
thing_inside
= [(Name, Id)] -> TcM a -> TcM a
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendIdEnv2 [(Id -> Name
idName Id
id, Id
id) | Id
id <- [Id]
ids] TcM a
thing_inside
tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
tcExtendIdEnv1 :: forall a. Name -> Id -> TcM a -> TcM a
tcExtendIdEnv1 Name
name Id
id TcM a
thing_inside
= [(Name, Id)] -> TcM a -> TcM a
forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendIdEnv2 [(Name
name,Id
id)] TcM a
thing_inside
tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
tcExtendIdEnv2 :: forall r. [(Name, Id)] -> TcM r -> TcM r
tcExtendIdEnv2 [(Name, Id)]
names_w_ids TcM a
thing_inside
= [TcBinder] -> TcM a -> TcM a
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [ Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
mono_id TopLevelFlag
NotTopLevel
| (Name
_,Id
mono_id) <- [(Name, Id)]
names_w_ids ] (TcM a -> TcM a) -> TcM a -> TcM a
forall a b. (a -> b) -> a -> b
$
TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel
[ (Name
name, ATcId { tct_id :: Id
tct_id = Id
id
, tct_info :: IdBindingInfo
tct_info = IdBindingInfo
NotLetBound })
| (Name
name,Id
id) <- [(Name, Id)]
names_w_ids]
TcM a
thing_inside
tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env :: forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
top_lvl [(Name, TcTyThing)]
extra_env TcM a
thing_inside
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tc_extend_local_env" ([(Name, TcTyThing)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [(Name, TcTyThing)]
extra_env)
; (TcLclCtxt -> TcLclCtxt) -> TcM a -> TcM a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt TcLclCtxt -> TcLclCtxt
upd_lcl_env TcM a
thing_inside }
where
upd_lcl_env :: TcLclCtxt -> TcLclCtxt
upd_lcl_env env0 :: TcLclCtxt
env0@(TcLclCtxt { tcl_th_ctxt :: TcLclCtxt -> ThStage
tcl_th_ctxt = ThStage
stage
, tcl_rdr :: TcLclCtxt -> LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env
, tcl_th_bndrs :: TcLclCtxt -> ThBindEnv
tcl_th_bndrs = ThBindEnv
th_bndrs
, tcl_env :: TcLclCtxt -> TcTypeEnv
tcl_env = TcTypeEnv
lcl_type_env })
= TcLclCtxt
env0 { tcl_rdr = extendLocalRdrEnvList rdr_env
[ n | (n, _) <- extra_env, isInternalName n ]
, tcl_th_bndrs = extendNameEnvList th_bndrs
[(n, thlvl) | (n, _) <- extra_env]
, tcl_env = extendNameEnvList lcl_type_env extra_env }
where
thlvl :: (TopLevelFlag, ThLevel)
thlvl = (TopLevelFlag
top_lvl, ThStage -> ThLevel
thLevel ThStage
stage)
tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt
tcExtendLocalTypeEnv :: [(Name, TcTyThing)] -> TcLclCtxt -> TcLclCtxt
tcExtendLocalTypeEnv [(Name, TcTyThing)]
tc_ty_things lcl_env :: TcLclCtxt
lcl_env@(TcLclCtxt { tcl_env :: TcLclCtxt -> TcTypeEnv
tcl_env = TcTypeEnv
lcl_type_env })
= TcLclCtxt
lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things }
tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack :: forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcBinder]
bndrs TcM a
thing_inside
= do { String -> SDoc -> IOEnv (Env TcGblEnv TcLclEnv) ()
traceTc String
"tcExtendBinderStack" ([TcBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcBinder]
bndrs)
; (TcLclCtxt -> TcLclCtxt) -> TcM a -> TcM a
forall gbl a.
(TcLclCtxt -> TcLclCtxt)
-> TcRnIf gbl TcLclEnv a -> TcRnIf gbl TcLclEnv a
updLclCtxt (\TcLclCtxt
env -> TcLclCtxt
env { tcl_bndrs = bndrs ++ tcl_bndrs env })
TcM a
thing_inside }
tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a
tcAddDataFamConPlaceholders :: forall a. [LInstDecl GhcRn] -> TcM a -> TcM a
tcAddDataFamConPlaceholders [LInstDecl GhcRn]
inst_decls TcM a
thing_inside
= [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
FamDataConPE)
| GenLocated SrcSpanAnnA (InstDecl GhcRn)
lid <- [LInstDecl GhcRn]
[GenLocated SrcSpanAnnA (InstDecl GhcRn)]
inst_decls, Name
con <- LInstDecl GhcRn -> [Name]
get_cons LInstDecl GhcRn
GenLocated SrcSpanAnnA (InstDecl GhcRn)
lid ]
TcM a
thing_inside
where
get_cons :: LInstDecl GhcRn -> [Name]
get_cons :: LInstDecl GhcRn -> [Name]
get_cons (L SrcSpanAnnA
_ (TyFamInstD {})) = []
get_cons (L SrcSpanAnnA
_ (DataFamInstD { dfid_inst :: forall pass. InstDecl pass -> DataFamInstDecl pass
dfid_inst = DataFamInstDecl GhcRn
fid })) = DataFamInstDecl GhcRn -> [Name]
get_fi_cons DataFamInstDecl GhcRn
fid
get_cons (L SrcSpanAnnA
_ (ClsInstD { cid_inst :: forall pass. InstDecl pass -> ClsInstDecl pass
cid_inst = ClsInstDecl { cid_datafam_insts :: forall pass. ClsInstDecl pass -> [LDataFamInstDecl pass]
cid_datafam_insts = [LDataFamInstDecl GhcRn]
fids } }))
= (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn) -> [Name])
-> [GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl GhcRn -> [Name])
-> (GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> DataFamInstDecl GhcRn)
-> GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)
-> DataFamInstDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl GhcRn]
[GenLocated SrcSpanAnnA (DataFamInstDecl GhcRn)]
fids
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons :: DataFamInstDecl GhcRn -> [Name]
get_fi_cons (DataFamInstDecl { dfid_eqn :: forall pass. DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)
dfid_eqn =
FamEqn { feqn_rhs :: forall pass rhs. FamEqn pass rhs -> rhs
feqn_rhs = HsDataDefn { dd_cons :: forall pass. HsDataDefn pass -> DataDefnCons (LConDecl pass)
dd_cons = DataDefnCons (LConDecl GhcRn)
cons } }})
= (LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc ([LocatedN Name] -> [Name]) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> [LocatedN Name])
-> DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
-> [LocatedN Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [LocatedN Name]
getConNames (ConDecl GhcRn -> [LocatedN Name])
-> (GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn)
-> GenLocated SrcSpanAnnA (ConDecl GhcRn)
-> [LocatedN Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpanAnnA (ConDecl GhcRn) -> ConDecl GhcRn
forall l e. GenLocated l e -> e
unLoc) DataDefnCons (LConDecl GhcRn)
DataDefnCons (GenLocated SrcSpanAnnA (ConDecl GhcRn))
cons
tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders :: forall a. [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a
tcAddPatSynPlaceholders [PatSynBind GhcRn GhcRn]
pat_syns TcM a
thing_inside
= [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
name, PromotionErr -> TcTyThing
APromotionErr PromotionErr
PatSynPE)
| PSB{ psb_id :: forall idL idR. PatSynBind idL idR -> LIdP idL
psb_id = L SrcSpanAnnN
_ Name
name } <- [PatSynBind GhcRn GhcRn]
pat_syns ]
TcM a
thing_inside
tcAddKindSigPlaceholders :: LHsKind GhcRn -> TcM a -> TcM a
tcAddKindSigPlaceholders :: forall a. LHsKind GhcRn -> TcM a -> TcM a
tcAddKindSigPlaceholders LHsKind GhcRn
kind_sig TcM a
thing_inside
= [(Name, TcTyThing)] -> TcM a -> TcM a
forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
name, PromotionErr -> TcTyThing
APromotionErr PromotionErr
TypeVariablePE)
| Name
name <- LHsKind GhcRn -> [Name]
hsScopedKvs LHsKind GhcRn
kind_sig ]
TcM a
thing_inside
getTypeSigNames :: [LSig GhcRn] -> NameSet
getTypeSigNames :: [LSig GhcRn] -> RhsNames
getTypeSigNames [LSig GhcRn]
sigs
= (GenLocated SrcSpanAnnA (Sig GhcRn) -> RhsNames -> RhsNames)
-> RhsNames -> [GenLocated SrcSpanAnnA (Sig GhcRn)] -> RhsNames
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LSig GhcRn -> RhsNames -> RhsNames
GenLocated SrcSpanAnnA (Sig GhcRn) -> RhsNames -> RhsNames
get_type_sig RhsNames
emptyNameSet [LSig GhcRn]
[GenLocated SrcSpanAnnA (Sig GhcRn)]
sigs
where
get_type_sig :: LSig GhcRn -> NameSet -> NameSet
get_type_sig :: LSig GhcRn -> RhsNames -> RhsNames
get_type_sig LSig GhcRn
sig RhsNames
ns =
case LSig GhcRn
sig of
L SrcSpanAnnA
_ (TypeSig XTypeSig GhcRn
_ [LIdP GhcRn]
names LHsSigWcType GhcRn
_) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[LocatedN Name]
names)
L SrcSpanAnnA
_ (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
_) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns ((LocatedN Name -> Name) -> [LocatedN Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map LocatedN Name -> Name
forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
[LocatedN Name]
names)
LSig GhcRn
_ -> RhsNames
ns
tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a
tcExtendRules :: forall a. [LRuleDecl GhcTc] -> TcM a -> TcM a
tcExtendRules [LRuleDecl GhcTc]
lcl_rules TcM a
thing_inside
= do { env <- TcRnIf TcGblEnv TcLclEnv TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let
env' = TcGblEnv
env { tcg_rules = lcl_rules ++ tcg_rules env }
; setGblEnv env' thing_inside }
checkWellStaged :: StageCheckReason
-> ThLevel
-> ThLevel
-> TcM ()
checkWellStaged :: StageCheckReason
-> ThLevel -> ThLevel -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkWellStaged StageCheckReason
pp_thing ThLevel
bind_lvl ThLevel
use_lvl
| ThLevel
use_lvl ThLevel -> ThLevel -> Bool
forall a. Ord a => a -> a -> Bool
>= ThLevel
bind_lvl
= () -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| ThLevel
bind_lvl ThLevel -> ThLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ThLevel
outerLevel
= TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcM a
failWithTc (StageCheckReason -> TcRnMessage
TcRnStageRestriction StageCheckReason
pp_thing)
| Bool
otherwise
= TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ())
-> TcRnMessage -> IOEnv (Env TcGblEnv TcLclEnv) ()
forall a b. (a -> b) -> a -> b
$
StageCheckReason -> ThLevel -> ThLevel -> TcRnMessage
TcRnBadlyStaged StageCheckReason
pp_thing ThLevel
bind_lvl ThLevel
use_lvl
topIdLvl :: Id -> ThLevel
topIdLvl :: Id -> ThLevel
topIdLvl Id
id | Id -> Bool
isLocalId Id
id = ThLevel
outerLevel
| Bool
otherwise = ThLevel
impLevel
tcMetaTy :: Name -> TcM Type
tcMetaTy :: Name -> TcM Type
tcMetaTy Name
tc_name = do
t <- Name -> TcM TyCon
tcLookupTyCon Name
tc_name
return (mkTyConTy t)
isBrackStage :: ThStage -> Bool
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = Bool
True
isBrackStage ThStage
_other = Bool
False
tcGetDefaultTys :: TcM (DefaultEnv,
Bool)
tcGetDefaultTys :: TcM (DefaultEnv, Bool)
tcGetDefaultTys
= do { dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let ovl_strings = Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings DynFlags
dflags
extended_defaults = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ExtendedDefaultRules DynFlags
dflags
builtinDefaults TyCon
cls [Type]
tys = ClassDefaults{ cd_class :: TyCon
cd_class = TyCon
cls
, cd_types :: [Type]
cd_types = [Type]
tys
, cd_module :: Maybe Module
cd_module = Maybe Module
forall a. Maybe a
Nothing
, cd_warn :: Maybe (WarningTxt GhcRn)
cd_warn = Maybe (WarningTxt GhcRn)
forall a. Maybe a
Nothing }
; defaults <- getDeclaredDefaultTys
; this_module <- tcg_mod <$> getGblEnv
; let this_unit = Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
this_module
is_internal_unit = Unit
this_unit Unit -> [Unit] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Unit
bignumUnit, Unit
ghcInternalUnit, Unit
primUnit]
; if is_internal_unit
then return (defaults, extended_defaults)
else do
{ extDef <- if extended_defaults
then do { list_ty <- tcMetaTy listTyConName
; integer_ty <- tcMetaTy integerTyConName
; foldableCls <- tcLookupTyCon foldableClassName
; showCls <- tcLookupTyCon showClassName
; eqCls <- tcLookupTyCon eqClassName
; pure $ defaultEnv
[ builtinDefaults foldableCls [list_ty]
, builtinDefaults showCls [unitTy, integer_ty, doubleTy]
, builtinDefaults eqCls [unitTy, integer_ty, doubleTy]
]
}
else pure emptyDefaultEnv
; ovlStr <- if ovl_strings
then do { isStringCls <- tcLookupTyCon isStringClassName
; pure $ unitDefaultEnv $ builtinDefaults isStringCls [stringTy]
}
else pure emptyDefaultEnv
; checkWiredInTyCon doubleTyCon
; numDef <- case lookupDefaultEnv defaults numClassName of
Maybe ClassDefaults
Nothing -> do { numCls <- Name -> TcM TyCon
tcLookupTyCon Name
numClassName
; integer_ty <- tcMetaTy integerTyConName
; pure $ unitDefaultEnv $ builtinDefaults numCls [integer_ty, doubleTy]
}
Maybe ClassDefaults
_ -> DefaultEnv -> TcRn DefaultEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DefaultEnv
emptyDefaultEnv
; let deflt_tys = [DefaultEnv] -> DefaultEnv
forall a. Monoid a => [a] -> a
mconcat [ DefaultEnv
extDef, DefaultEnv
numDef, DefaultEnv
ovlStr, DefaultEnv
defaults ]
; return (deflt_tys, extended_defaults) } }
data InstInfo a
= InstInfo
{ forall a. InstInfo a -> ClsInst
iSpec :: ClsInst
, forall a. InstInfo a -> InstBindings a
iBinds :: InstBindings a
}
iDFunId :: InstInfo a -> DFunId
iDFunId :: forall a. InstInfo a -> Id
iDFunId InstInfo a
info = ClsInst -> Id
instanceDFunId (InstInfo a -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo a
info)
data InstBindings a
= InstBindings
{ forall a. InstBindings a -> [Name]
ib_tyvars :: [Name]
, forall a. InstBindings a -> LHsBinds a
ib_binds :: LHsBinds a
, forall a. InstBindings a -> [LSig a]
ib_pragmas :: [LSig a]
, forall a. InstBindings a -> [Extension]
ib_extensions :: [LangExt.Extension]
, forall a. InstBindings a -> Bool
ib_derived :: Bool
}
instance (OutputableBndrId a)
=> Outputable (InstInfo (GhcPass a)) where
ppr :: InstInfo (GhcPass a) -> SDoc
ppr = InstInfo (GhcPass a) -> SDoc
forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails
pprInstInfoDetails :: (OutputableBndrId a)
=> InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails :: forall (a :: Pass).
OutputableBndrId a =>
InstInfo (GhcPass a) -> SDoc
pprInstInfoDetails InstInfo (GhcPass a)
info
= SDoc -> ThLevel -> SDoc -> SDoc
hang (ClsInst -> SDoc
pprInstanceHdr (InstInfo (GhcPass a) -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo (GhcPass a)
info) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"where")
ThLevel
2 (InstBindings (GhcPass a) -> SDoc
forall {id2 :: Pass}.
(OutputableBndr (IdGhcP id2),
OutputableBndr (IdGhcP (NoGhcTcPass id2)), IsPass id2,
Outputable (GenLocated (Anno (IdGhcP id2)) (IdGhcP id2)),
Outputable
(GenLocated
(Anno (IdGhcP (NoGhcTcPass id2))) (IdGhcP (NoGhcTcPass id2)))) =>
InstBindings (GhcPass id2) -> SDoc
details (InstInfo (GhcPass a) -> InstBindings (GhcPass a)
forall a. InstInfo a -> InstBindings a
iBinds InstInfo (GhcPass a)
info))
where
details :: InstBindings (GhcPass id2) -> SDoc
details (InstBindings { ib_pragmas :: forall a. InstBindings a -> [LSig a]
ib_pragmas = [LSig (GhcPass id2)]
p, ib_binds :: forall a. InstBindings a -> LHsBinds a
ib_binds = LHsBinds (GhcPass id2)
b }) =
[SDoc] -> SDoc
pprDeclList (LHsBinds (GhcPass id2) -> [LSig (GhcPass id2)] -> [SDoc]
forall (idL :: Pass) (idR :: Pass) (id2 :: Pass).
(OutputableBndrId idL, OutputableBndrId idR,
OutputableBndrId id2) =>
LHsBindsLR (GhcPass idL) (GhcPass idR)
-> [LSig (GhcPass id2)] -> [SDoc]
pprLHsBindsForUser LHsBinds (GhcPass id2)
b [LSig (GhcPass id2)]
p)
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy :: forall a. InstInfo a -> (Class, Type)
simpleInstInfoClsTy InstInfo a
info = case ClsInst -> ([Id], Class, [Type])
instanceHead (InstInfo a -> ClsInst
forall a. InstInfo a -> ClsInst
iSpec InstInfo a
info) of
([Id]
_, Class
cls, [Type
ty]) -> (Class
cls, Type
ty)
([Id], Class, [Type])
_ -> String -> (Class, Type)
forall a. HasCallStack => String -> a
panic String
"simpleInstInfoClsTy"
simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy :: forall a. InstInfo a -> Type
simpleInstInfoTy InstInfo a
info = (Class, Type) -> Type
forall a b. (a, b) -> b
snd (InstInfo a -> (Class, Type)
forall a. InstInfo a -> (Class, Type)
simpleInstInfoClsTy InstInfo a
info)
simpleInstInfoTyCon :: InstInfo a -> TyCon
simpleInstInfoTyCon :: forall a. InstInfo a -> TyCon
simpleInstInfoTyCon InstInfo a
inst = Type -> TyCon
tcTyConAppTyCon (InstInfo a -> Type
forall a. InstInfo a -> Type
simpleInstInfoTy InstInfo a
inst)
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
newDFunName Class
clas [Type]
tys SrcSpan
loc
= do { is_boot <- TcRnIf TcGblEnv TcLclEnv Bool
tcIsHsBootOrSig
; mod <- getModule
; let info_string = OccName -> String
occNameString (Class -> OccName
forall a. NamedThing a => a -> OccName
getOccName Class
clas) String -> String -> String
forall a. [a] -> [a] -> [a]
++
(Type -> String) -> [Type] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OccName -> String
occNameString (OccName -> String) -> (Type -> OccName) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> OccName
getDFunTyKey) [Type]
tys
; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (L SrcSpanAnnN
loc Name
name) [Type]
tys = (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
forall a. a -> a
id (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) Name
name [[Type]
tys]
newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name
newFamInstAxiomName (L SrcSpanAnnN
loc Name
name) [[Type]]
branches
= (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
mkInstTyCoOcc (SrcSpanAnnN -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnN
loc) Name
name [[Type]]
branches
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
mk_fam_inst_name OccName -> OccName
adaptOcc SrcSpan
loc Name
tc_name [[Type]]
tyss
= do { mod <- IOEnv (Env TcGblEnv TcLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
; let info_string = OccName -> String
occNameString (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
tc_name) String -> String -> String
forall a. [a] -> [a] -> [a]
++
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" [String]
ty_strings
; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
; newGlobalBinder mod (adaptOcc occ) loc }
where
ty_strings :: [String]
ty_strings = ([Type] -> String) -> [[Type]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> String) -> [Type] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OccName -> String
occNameString (OccName -> String) -> (Type -> OccName) -> Type -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> OccName
getDFunTyKey)) [[Type]]
tyss
mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromString String
str Type
sig_ty SrcSpan
loc OccName -> OccName
occ_wrapper = do
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
mod <- getModule
nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv
name <- mkWrapperName nextWrapperNum "stable" str
let occ = FastString -> OccName
mkVarOccFS FastString
name :: OccName
gnm = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod (OccName -> OccName
occ_wrapper OccName
occ) SrcSpan
loc :: Name
id = Name -> Type -> Id
mkExportedVanillaId Name
gnm Type
sig_ty :: Id
return id
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId
mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromName Name
nm = String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM Id
mkStableIdFromString (Name -> String
forall a. NamedThing a => a -> String
getOccString Name
nm)
mkWrapperName :: (MonadIO m, HasModule m)
=> IORef (ModuleEnv Int) -> String -> String -> m FastString
mkWrapperName :: forall (m :: * -> *).
(MonadIO m, HasModule m) =>
TcRef (ModuleEnv ThLevel) -> String -> String -> m FastString
mkWrapperName TcRef (ModuleEnv ThLevel)
wrapperRef String
what String
nameBase
= do thisMod <- m Module
forall (m :: * -> *). HasModule m => m Module
getModule
let pkg = Unit -> String
forall u. IsUnitId u => u -> String
unitString (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
thisMod)
mod = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
thisMod)
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \ModuleEnv ThLevel
mod_env ->
let num :: ThLevel
num = ModuleEnv ThLevel -> ThLevel -> Module -> ThLevel
forall a. ModuleEnv a -> a -> Module -> a
lookupWithDefaultModuleEnv ModuleEnv ThLevel
mod_env ThLevel
0 Module
thisMod
mod_env' :: ModuleEnv ThLevel
mod_env' = ModuleEnv ThLevel -> Module -> ThLevel -> ModuleEnv ThLevel
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv ThLevel
mod_env Module
thisMod (ThLevel
numThLevel -> ThLevel -> ThLevel
forall a. Num a => a -> a -> a
+ThLevel
1)
in (ModuleEnv ThLevel
mod_env', ThLevel
num)
let components = [String
what, ThLevel -> String
forall a. Show a => a -> String
show ThLevel
wrapperNum, String
pkg, String
mod, String
nameBase]
return $ mkFastString $ zEncodeString $ intercalate ":" components
pprBinders :: [Name] -> SDoc
pprBinders :: [Name] -> SDoc
pprBinders [Name
bndr] = SDoc -> SDoc
quotes (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
bndr)
pprBinders [Name]
bndrs = (Name -> SDoc) -> [Name] -> SDoc
forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Name]
bndrs
notFound :: Name -> TcM TyThing
notFound :: Name -> TcM TyThing
notFound Name
name
= do { lcl_env <- TcRnIf TcGblEnv TcLclEnv TcLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let stage = TcLclEnv -> ThStage
getLclEnvThStage TcLclEnv
lcl_env
; case stage of
Splice {}
| Name -> Bool
isUnboundName Name
name -> TcM TyThing
forall env a. IOEnv env a
failM
| Bool
otherwise -> TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (StageCheckReason -> TcRnMessage
TcRnStageRestriction (Name -> StageCheckReason
StageCheckSplice Name
name))
ThStage
_ | NameSpace -> Bool
isTermVarOrFieldNameSpace (Name -> NameSpace
nameNameSpace Name
name) ->
TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TyThing) -> TcRnMessage -> TcM TyThing
forall a b. (a -> b) -> a -> b
$ Name -> PromotionErr -> TcRnMessage
TcRnUnpromotableThing Name
name PromotionErr
TermVariablePE
| Bool
otherwise -> TcRnMessage -> TcM TyThing
forall a. TcRnMessage -> TcM a
failWithTc (TcRnMessage -> TcM TyThing) -> TcRnMessage -> TcM TyThing
forall a b. (a -> b) -> a -> b
$
RdrName -> NotInScopeError -> TcRnMessage
mkTcRnNotInScope (Name -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Name
name) (TcTypeEnv -> NotInScopeError
NotInScopeTc (TcLclEnv -> TcTypeEnv
getLclEnvTypeEnv TcLclEnv
lcl_env))
}
wrongThingErr :: WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr :: forall a. WrongThingSort -> TcTyThing -> Name -> TcM a
wrongThingErr WrongThingSort
expected TcTyThing
thing Name
name =
TcRnMessage -> TcM a
forall a. TcRnMessage -> TcM a
failWithTc (WrongThingSort -> TcTyThing -> Name -> TcRnMessage
TcRnTyThingUsedWrong WrongThingSort
expected TcTyThing
thing Name
name)