{-# LANGUAGE CPP, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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,
tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,
tcLookupTyCon, tcLookupClass,
tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass, tcLookupAxiom,
lookupGlobal, ioLookupDataCon,
addTypecheckedBinds,
tcExtendKindEnv, tcExtendKindEnvList,
tcExtendTyVarEnv, tcExtendNameTyVarEnv,
tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,
tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
tcExtendBinderStack, tcExtendLocalTypeEnv,
isTypeClosedLetBndr,
tcCheckUsage,
tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupIdMaybe, tcLookupTyVar,
tcLookupTcTyCon,
tcLookupLcl_maybe,
getInLocalScope,
wrongThingErr, pprBinders,
tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
getTypeSigNames,
tcExtendRecEnv,
tcInitTidyEnv, tcInitOpenTidyEnv,
tcLookupInstance, tcGetInstEnvs,
tcExtendRules,
tcGetDefaultTys,
checkWellStaged, tcMetaTy, thLevel,
topIdLvl, isBrackStage,
newDFunName,
newFamInstTyConName, newFamInstAxiomName,
mkStableIdFromString, mkStableIdFromName,
mkWrapperName
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.Session
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.Utils.Monad
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper)
import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult )
import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )
import GHC.Core.UsageEnv
import GHC.Core.InstEnv
import GHC.Core.DataCon ( DataCon )
import GHC.Core.PatSyn ( PatSyn )
import GHC.Core.ConLike
import GHC.Core.TyCon
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.Bag
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.Id
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Name.Reader
import GHC.Types.TyThing
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
import Data.List (intercalate)
import Control.Monad
lookupGlobal :: HscEnv -> Name -> IO TyThing
lookupGlobal :: HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
name
= do {
MaybeErr SDoc TyThing
mb_thing <- HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
; case MaybeErr SDoc TyThing
mb_thing of
Succeeded TyThing
thing -> forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
Failed SDoc
msg -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupGlobal" SDoc
msg
}
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupGlobal_maybe HscEnv
hsc_env Name
name
= do {
let mod :: Module
mod = InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
tcg_semantic_mod :: Module
tcg_semantic_mod = HomeUnit -> Module -> Module
homeModuleInstantiation HomeUnit
home_unit Module
mod
; if Module -> Name -> Bool
nameIsLocalOrFrom Module
tcg_semantic_mod Name
name
then (forall (m :: * -> *) a. Monad m => a -> m a
return
(forall err val. err -> MaybeErr err val
Failed (String -> SDoc
text String
"Can't find local name: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Name
name)))
else
HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
}
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
lookupImported_maybe HscEnv
hsc_env Name
name
= do { Maybe TyThing
mb_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
name
; case Maybe TyThing
mb_thing of
Just TyThing
thing -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall err val. val -> MaybeErr err val
Succeeded TyThing
thing)
Maybe TyThing
Nothing -> HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
importDecl_maybe HscEnv
hsc_env Name
name
}
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing)
importDecl_maybe HscEnv
hsc_env Name
name
| Just TyThing
thing <- Name -> Maybe TyThing
wiredInNameTyThing_maybe Name
name
= do { forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TyThing -> Bool
needWiredInHomeIface TyThing
thing)
(forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (forall lcl. Name -> IfM lcl ()
loadWiredInHomeIface Name
name))
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall err val. val -> MaybeErr err val
Succeeded TyThing
thing) }
| Bool
otherwise
= forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (forall lcl. Name -> IfM lcl (MaybeErr SDoc TyThing)
importDecl Name
name)
ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon :: HscEnv -> Name -> IO DataCon
ioLookupDataCon HscEnv
hsc_env Name
name = do
MaybeErr SDoc DataCon
mb_thing <- HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
ioLookupDataCon_maybe HscEnv
hsc_env Name
name
case MaybeErr SDoc DataCon
mb_thing of
Succeeded DataCon
thing -> forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
thing
Failed SDoc
msg -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupDataConIO" SDoc
msg
ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon)
ioLookupDataCon_maybe HscEnv
hsc_env Name
name = do
TyThing
thing <- HscEnv -> Name -> IO TyThing
lookupGlobal HscEnv
hsc_env Name
name
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case TyThing
thing of
AConLike (RealDataCon DataCon
con) -> forall err val. val -> MaybeErr err val
Succeeded DataCon
con
TyThing
_ -> forall err val. err -> MaybeErr err val
Failed forall a b. (a -> b) -> a -> b
$
TcTyThing -> SDoc
pprTcTyThingCategory (TyThing -> TcTyThing
AGlobal TyThing
thing) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"used as a data constructor"
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 :: LHsBinds GhcTc
tcg_binds = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Bag a -> Bag a -> Bag a
unionBags
(TcGblEnv -> LHsBinds GhcTc
tcg_binds TcGblEnv
tcg_env)
[LHsBinds GhcTc]
binds }
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing
tcLookupLocatedGlobal LocatedA Name
name
= forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Name -> TcM TyThing
tcLookupGlobal LocatedA Name
name
tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal :: Name -> TcM TyThing
tcLookupGlobal Name
name
= do {
TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
env) Name
name of {
Just TyThing
thing -> 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 { MaybeErr SDoc TyThing
mb_thing <- Name -> TcM (MaybeErr SDoc TyThing)
tcLookupImported_maybe Name
name
; case MaybeErr SDoc TyThing
mb_thing of
Succeeded TyThing
thing -> forall (m :: * -> *) a. Monad m => a -> m a
return TyThing
thing
Failed SDoc
msg -> forall a. SDoc -> TcM a
failWithTc SDoc
msg
}}}
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly :: Name -> TcM TyThing
tcLookupGlobalOnly Name
name
= do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
env) Name
name of
Just TyThing
thing -> TyThing
thing
Maybe TyThing
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupGlobalOnly" (forall a. Outputable a => a -> SDoc
ppr Name
name) }
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon Name
name = do
TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case TyThing
thing of
AConLike (RealDataCon DataCon
con) -> forall (m :: * -> *) a. Monad m => a -> m a
return DataCon
con
TyThing
_ -> forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"data constructor" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn :: Name -> TcM PatSyn
tcLookupPatSyn Name
name = do
TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case TyThing
thing of
AConLike (PatSynCon PatSyn
ps) -> forall (m :: * -> *) a. Monad m => a -> m a
return PatSyn
ps
TyThing
_ -> forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"pattern synonym" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike :: Name -> TcM ConLike
tcLookupConLike Name
name = do
TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case TyThing
thing of
AConLike ConLike
cl -> forall (m :: * -> *) a. Monad m => a -> m a
return ConLike
cl
TyThing
_ -> forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"constructor-like thing" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupClass :: Name -> TcM Class
tcLookupClass :: Name -> TcM Class
tcLookupClass Name
name = do
TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case TyThing
thing of
ATyCon TyCon
tc | Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc -> forall (m :: * -> *) a. Monad m => a -> m a
return Class
cls
TyThing
_ -> forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"class" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon :: Name -> TcM TyCon
tcLookupTyCon Name
name = do
TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case TyThing
thing of
ATyCon TyCon
tc -> forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
TyThing
_ -> forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"type constructor" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom :: Name -> TcM (CoAxiom Branched)
tcLookupAxiom Name
name = do
TyThing
thing <- Name -> TcM TyThing
tcLookupGlobal Name
name
case TyThing
thing of
ACoAxiom CoAxiom Branched
ax -> forall (m :: * -> *) a. Monad m => a -> m a
return CoAxiom Branched
ax
TyThing
_ -> forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
"axiom" (TyThing -> TcTyThing
AGlobal TyThing
thing) Name
name
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id
tcLookupLocatedGlobalId = forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Name -> TcM Id
tcLookupId
tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass :: LocatedA Name -> TcM Class
tcLookupLocatedClass = forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Name -> TcM Class
tcLookupClass
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon
tcLookupLocatedTyCon = forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Name -> TcM TyCon
tcLookupTyCon
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance :: Class -> [Type] -> TcM ClsInst
tcLookupInstance Class
cls [Type]
tys
= do { InstEnvs
instEnv <- TcM InstEnvs
tcGetInstEnvs
; case InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type])
lookupUniqueInstEnv InstEnvs
instEnv Class
cls [Type]
tys of
Left SDoc
err -> forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Couldn't match instance:" SDoc -> SDoc -> SDoc
<+> SDoc
err
Right (ClsInst
inst, [Type]
tys)
| [Type] -> Bool
uniqueTyVars [Type]
tys -> forall (m :: * -> *) a. Monad m => a -> m a
return ClsInst
inst
| Bool
otherwise -> forall a. SDoc -> TcM a
failWithTc SDoc
errNotExact
}
where
errNotExact :: SDoc
errNotExact = String -> SDoc
text String
"Not an exact match (i.e., some variables get instantiated)"
uniqueTyVars :: [Type] -> Bool
uniqueTyVars [Type]
tys = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Type -> Bool
isTyVarTy [Type]
tys
Bool -> Bool -> Bool
&& forall a. Eq a => [a] -> Bool
hasNoDups (forall a b. (a -> b) -> [a] -> [b]
map (String -> Type -> Id
getTyVar String
"tcLookupInstance") [Type]
tys)
tcGetInstEnvs :: TcM InstEnvs
tcGetInstEnvs :: TcM InstEnvs
tcGetInstEnvs = do { ExternalPackageState
eps <- forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnvs { ie_global :: InstEnv
ie_global = ExternalPackageState -> InstEnv
eps_inst_env ExternalPackageState
eps
, ie_local :: InstEnv
ie_local = TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
env
, ie_visible :: VisibleOrphanModules
ie_visible = TcGblEnv -> VisibleOrphanModules
tcVisibleOrphanMods TcGblEnv
env }) }
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing :: Name -> TcM TyThing
lookupThing = Name -> TcM TyThing
tcLookupGlobal
setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env TypeEnv
new_type_env
= do {
forall a env. IORef a -> a -> IOEnv env ()
writeMutVar (TcGblEnv -> TcRef TypeEnv
tcg_type_env_var TcGblEnv
tcg_env) TypeEnv
new_type_env
; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env { tcg_type_env :: TypeEnv
tcg_type_env = TypeEnv
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 { TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let ge' :: TypeEnv
ge' = TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env) [TyThing]
things
; TcGblEnv
tcg_env' <- TcGblEnv -> TypeEnv -> TcM TcGblEnv
setGlobalTypeEnv TcGblEnv
tcg_env TypeEnv
ge'
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' TcM r
thing_inside }
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv :: forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv [TyThing]
things TcM r
thing_inside
= do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let env' :: TcGblEnv
env' = TcGblEnv
env { tcg_tcs :: [TyCon]
tcg_tcs = [TyCon
tc | ATyCon TyCon
tc <- [TyThing]
things] forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
env,
tcg_patsyns :: [PatSyn]
tcg_patsyns = [PatSyn
ps | AConLike (PatSynCon PatSyn
ps) <- [TyThing]
things] forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [PatSyn]
tcg_patsyns TcGblEnv
env }
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' forall a b. (a -> b) -> a -> b
$
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
things TcM r
thing_inside
}
tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv :: forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tycons TcM r
thing_inside
= do { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let env' :: TcGblEnv
env' = TcGblEnv
env { tcg_tcs :: [TyCon]
tcg_tcs = [TyCon]
tycons forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [TyCon]
tcg_tcs TcGblEnv
env }
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' forall a b. (a -> b) -> a -> b
$
forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
tycons) TcM r
thing_inside
}
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
ids TcM a
thing_inside
= 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 { TcGblEnv
tcg_env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let ge' :: TypeEnv
ge' = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcGblEnv -> TypeEnv
tcg_type_env TcGblEnv
tcg_env) [(Name, TyThing)]
gbl_stuff
tcg_env' :: TcGblEnv
tcg_env' = TcGblEnv
tcg_env { tcg_type_env :: TypeEnv
tcg_type_env = TypeEnv
ge' }
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
tcg_env' TcM r
thing_inside }
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated :: LocatedA Name -> TcM TcTyThing
tcLookupLocated = forall a b ann.
(a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b
addLocMA Name -> TcM TcTyThing
tcLookup
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)
tcLookupLcl_maybe Name
name
= do { TcTypeEnv
local_env <- TcM TcTypeEnv
getLclTypeEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
local_env Name
name) }
tcLookup :: Name -> TcM TcTyThing
tcLookup :: Name -> TcM TcTyThing
tcLookup Name
name = do
TcTypeEnv
local_env <- TcM TcTypeEnv
getLclTypeEnv
case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv TcTypeEnv
local_env Name
name of
Just TcTyThing
thing -> forall (m :: * -> *) a. Monad m => a -> m a
return TcTyThing
thing
Maybe TcTyThing
Nothing -> (TyThing -> TcTyThing
AGlobal 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 { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case TcTyThing
thing of
ATyVar Name
_ Id
tv -> forall (m :: * -> *) a. Monad m => a -> m a
return Id
tv
TcTyThing
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupTyVar" (forall a. Outputable a => a -> SDoc
ppr Name
name) }
tcLookupId :: Name -> TcM Id
tcLookupId :: Name -> TcM Id
tcLookupId Name
name = do
Maybe Id
thing <- Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
case Maybe Id
thing of
Just Id
id -> forall (m :: * -> *) a. Monad m => a -> m a
return Id
id
Maybe Id
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupId" (forall a. Outputable a => a -> SDoc
ppr Name
name)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe :: Name -> TcM (Maybe Id)
tcLookupIdMaybe Name
name
= do { TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
; case TcTyThing
thing of
ATcId { tct_id :: TcTyThing -> Id
tct_id = Id
id} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Id
id
AGlobal (AnId Id
id) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Id
id
TcTyThing
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing }
tcLookupLocalIds :: [Name] -> TcM [TcId]
tcLookupLocalIds :: [Name] -> TcM [Id]
tcLookupLocalIds [Name]
ns
= do { TcLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (TcTypeEnv -> Name -> Id
lookup (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env)) [Name]
ns) }
where
lookup :: TcTypeEnv -> Name -> Id
lookup TcTypeEnv
lenv Name
name
= case 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
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupLocalIds" (forall a. Outputable a => a -> SDoc
ppr Name
name)
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TcTyCon
tcLookupTcTyCon :: HasDebugCallStack => Name -> TcM TyCon
tcLookupTcTyCon Name
name = do
TcTyThing
thing <- Name -> TcM TcTyThing
tcLookup Name
name
case TcTyThing
thing of
ATcTyCon TyCon
tc -> forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tc
TcTyThing
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcLookupTcTyCon" (forall a. Outputable a => a -> SDoc
ppr Name
name)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope :: TcM (Name -> Bool)
getInLocalScope = do { TcTypeEnv
lcl_env <- TcM TcTypeEnv
getLclTypeEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Name -> NameEnv a -> Bool
`elemNameEnv` TcTypeEnv
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 -> TcRn ()
traceTc String
"tcExtendKindEnvList" (forall a. Outputable a => a -> SDoc
ppr [(Name, TcTyThing)]
things)
; forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd_env TcM r
thing_inside }
where
upd_env :: TcLclEnv -> TcLclEnv
upd_env TcLclEnv
env = TcLclEnv
env { tcl_env :: TcTypeEnv
tcl_env = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env) [(Name, TcTyThing)]
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 -> TcRn ()
traceTc String
"tcExtendKindEnv" (forall a. Outputable a => a -> SDoc
ppr TcTypeEnv
extra_env)
; forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv TcLclEnv -> TcLclEnv
upd_env TcM r
thing_inside }
where
upd_env :: TcLclEnv -> TcLclEnv
upd_env TcLclEnv
env = TcLclEnv
env { tcl_env :: TcTypeEnv
tcl_env = TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
env forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` TcTypeEnv
extra_env }
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendTyVarEnv [Id]
tvs TcM r
thing_inside
= 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
= forall a. TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a
tc_extend_local_env TopLevelFlag
NotTopLevel [(Name, TcTyThing)]
names forall a b. (a -> b) -> a -> b
$
forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcBinder]
tv_binds 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 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
= 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 ] 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
= 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
-> [TcId] -> TcM a -> TcM a
tcExtendLetEnv :: forall a.
TopLevelFlag -> TcSigFun -> IsGroupClosed -> [Id] -> TcM a -> TcM a
tcExtendLetEnv TopLevelFlag
top_lvl TcSigFun
sig_fn (IsGroupClosed NameEnv RhsNames
fvs Bool
fv_type_closed)
[Id]
ids TcM a
thing_inside
= forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [Id -> TopLevelFlag -> TcBinder
TcIdBndr Id
id TopLevelFlag
top_lvl | Id
id <- [Id]
ids] forall a b. (a -> b) -> a -> b
$
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 })
| Id
id <- [Id]
ids ]
TcM a
thing_inside
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 = forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv RhsNames
fvs Name
name 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)
tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
tcExtendIdEnv :: forall a. [Id] -> TcM a -> TcM a
tcExtendIdEnv [Id]
ids TcM a
thing_inside
= 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
= 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
= 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 ] forall a b. (a -> b) -> a -> b
$
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 -> TcRn ()
traceTc String
"tc_extend_local_env" (forall a. Outputable a => a -> SDoc
ppr [(Name, TcTyThing)]
extra_env)
; ThStage
stage <- TcM ThStage
getStage
; env0 :: TcLclEnv
env0@(TcLclEnv { tcl_rdr :: TcLclEnv -> LocalRdrEnv
tcl_rdr = LocalRdrEnv
rdr_env
, tcl_th_bndrs :: TcLclEnv -> ThBindEnv
tcl_th_bndrs = ThBindEnv
th_bndrs
, tcl_env :: TcLclEnv -> TcTypeEnv
tcl_env = TcTypeEnv
lcl_type_env }) <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let thlvl :: (TopLevelFlag, ThLevel)
thlvl = (TopLevelFlag
top_lvl, ThStage -> ThLevel
thLevel ThStage
stage)
env1 :: TcLclEnv
env1 = TcLclEnv
env0 { tcl_rdr :: LocalRdrEnv
tcl_rdr = LocalRdrEnv -> [Name] -> LocalRdrEnv
extendLocalRdrEnvList LocalRdrEnv
rdr_env
[ Name
n | (Name
n, TcTyThing
_) <- [(Name, TcTyThing)]
extra_env, Name -> Bool
isInternalName Name
n ]
, tcl_th_bndrs :: ThBindEnv
tcl_th_bndrs = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList ThBindEnv
th_bndrs
[(Name
n, (TopLevelFlag, ThLevel)
thlvl) | (Name
n, ATcId {}) <- [(Name, TcTyThing)]
extra_env]
, tcl_env :: TcTypeEnv
tcl_env = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList TcTypeEnv
lcl_type_env [(Name, TcTyThing)]
extra_env }
; forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv TcLclEnv
env1 TcM a
thing_inside }
tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcLclEnv
tcExtendLocalTypeEnv lcl_env :: TcLclEnv
lcl_env@(TcLclEnv { tcl_env :: TcLclEnv -> TcTypeEnv
tcl_env = TcTypeEnv
lcl_type_env }) [(Name, TcTyThing)]
tc_ty_things
= TcLclEnv
lcl_env { tcl_env :: TcTypeEnv
tcl_env = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList TcTypeEnv
lcl_type_env [(Name, TcTyThing)]
tc_ty_things }
tcCheckUsage :: Name -> Mult -> TcM a -> TcM (a, HsWrapper)
tcCheckUsage :: forall a. Name -> Type -> TcM a -> TcM (a, HsWrapper)
tcCheckUsage Name
name Type
id_mult TcM a
thing_inside
= do { (UsageEnv
local_usage, a
result) <- forall a. TcM a -> TcM (UsageEnv, a)
tcCollectingUsage TcM a
thing_inside
; HsWrapper
wrapper <- UsageEnv -> TcM HsWrapper
check_then_add_usage UsageEnv
local_usage
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
result, HsWrapper
wrapper) }
where
check_then_add_usage :: UsageEnv -> TcM HsWrapper
check_then_add_usage :: UsageEnv -> TcM HsWrapper
check_then_add_usage UsageEnv
uenv
= do { let actual_u :: Usage
actual_u = forall n. NamedThing n => UsageEnv -> n -> Usage
lookupUE UsageEnv
uenv Name
name
; String -> SDoc -> TcRn ()
traceTc String
"check_then_add_usage" (forall a. Outputable a => a -> SDoc
ppr Type
id_mult SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Usage
actual_u)
; HsWrapper
wrapper <- case Usage
actual_u of
Usage
Bottom -> forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
Usage
Zero -> CtOrigin -> Type -> Type -> TcM HsWrapper
tcSubMult (Name -> CtOrigin
UsageEnvironmentOf Name
name) Type
Many Type
id_mult
MUsage Type
m -> do { Type
m <- Type -> IOEnv (Env TcGblEnv TcLclEnv) Type
promote_mult Type
m
; CtOrigin -> Type -> Type -> TcM HsWrapper
tcSubMult (Name -> CtOrigin
UsageEnvironmentOf Name
name) Type
m Type
id_mult }
; UsageEnv -> TcRn ()
tcEmitBindingUsage (forall n. NamedThing n => UsageEnv -> n -> UsageEnv
deleteUE UsageEnv
uenv Name
name)
; forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
wrapper }
promote_mult :: Type -> IOEnv (Env TcGblEnv TcLclEnv) Type
promote_mult Type
m = do { TyCoVarSet
fvs <- TyCoVarSet -> TcM TyCoVarSet
zonkTyCoVarsAndFV (Type -> TyCoVarSet
tyCoVarsOfType Type
m)
; Bool
any_promoted <- TyCoVarSet -> TcM Bool
promoteTyVarSet TyCoVarSet
fvs
; if Bool
any_promoted then Type -> IOEnv (Env TcGblEnv TcLclEnv) Type
zonkTcType Type
m else forall (m :: * -> *) a. Monad m => a -> m a
return Type
m
}
tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack :: forall a. [TcBinder] -> TcM a -> TcM a
tcExtendBinderStack [TcBinder]
bndrs TcM a
thing_inside
= do { String -> SDoc -> TcRn ()
traceTc String
"tcExtendBinderStack" (forall a. Outputable a => a -> SDoc
ppr [TcBinder]
bndrs)
; forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv (\TcLclEnv
env -> TcLclEnv
env { tcl_bndrs :: [TcBinder]
tcl_bndrs = [TcBinder]
bndrs forall a. [a] -> [a] -> [a]
++ TcLclEnv -> [TcBinder]
tcl_bndrs TcLclEnv
env })
TcM a
thing_inside }
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
= do { TcLclEnv
lcl_env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; TidyEnv -> [TcBinder] -> TcM TidyEnv
go TidyEnv
emptyTidyEnv (TcLclEnv -> [TcBinder]
tcl_bndrs TcLclEnv
lcl_env) }
where
go :: TidyEnv -> [TcBinder] -> TcM TidyEnv
go (UniqFM FastString ThLevel
env, UniqFM Id Id
subst) []
= forall (m :: * -> *) a. Monad m => a -> m a
return (UniqFM FastString ThLevel
env, UniqFM Id Id
subst)
go (UniqFM FastString ThLevel
env, UniqFM Id Id
subst) (TcBinder
b : [TcBinder]
bs)
| TcTvBndr Name
name Id
tyvar <- TcBinder
b
= do { let (UniqFM FastString ThLevel
env', OccName
occ') = UniqFM FastString ThLevel
-> OccName -> (UniqFM FastString ThLevel, OccName)
tidyOccName UniqFM FastString ThLevel
env (Name -> OccName
nameOccName Name
name)
name' :: Name
name' = Name -> OccName -> Name
tidyNameOcc Name
name OccName
occ'
tyvar1 :: Id
tyvar1 = Id -> Name -> Id
setTyVarName Id
tyvar Name
name'
; Id
tyvar2 <- HasDebugCallStack => Id -> TcM Id
zonkTcTyVarToTyVar Id
tyvar1
; TidyEnv -> [TcBinder] -> TcM TidyEnv
go (UniqFM FastString ThLevel
env', forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv UniqFM Id Id
subst Id
tyvar Id
tyvar2) [TcBinder]
bs }
| Bool
otherwise
= TidyEnv -> [TcBinder] -> TcM TidyEnv
go (UniqFM FastString ThLevel
env, UniqFM Id Id
subst) [TcBinder]
bs
tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv
tcInitOpenTidyEnv :: [Id] -> TcM TidyEnv
tcInitOpenTidyEnv [Id]
tvs
= do { TidyEnv
env1 <- TcM TidyEnv
tcInitTidyEnv
; let env2 :: TidyEnv
env2 = TidyEnv -> [Id] -> TidyEnv
tidyFreeTyCoVars TidyEnv
env1 [Id]
tvs
; forall (m :: * -> *) a. Monad m => a -> m a
return TidyEnv
env2 }
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
= forall r. [(Name, TcTyThing)] -> TcM r -> TcM r
tcExtendKindEnvList [ (Name
con, PromotionErr -> TcTyThing
APromotionErr PromotionErr
FamDataConPE)
| GenLocated SrcSpanAnnA (InstDecl GhcRn)
lid <- [LInstDecl GhcRn]
inst_decls, Name
con <- LInstDecl GhcRn -> [Name]
get_cons 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 } }))
= forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DataFamInstDecl GhcRn -> [Name]
get_fi_cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LDataFamInstDecl 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 -> [LConDecl pass]
dd_cons = [LConDecl GhcRn]
cons } }})
= forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ConDecl GhcRn -> [LocatedN Name]
getConNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc) [LConDecl 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
= 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
getTypeSigNames :: [LSig GhcRn] -> NameSet
getTypeSigNames :: [LSig GhcRn] -> RhsNames
getTypeSigNames [LSig GhcRn]
sigs
= forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LSig GhcRn -> RhsNames -> RhsNames
get_type_sig RhsNames
emptyNameSet [LSig 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 (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
names)
L SrcSpanAnnA
_ (PatSynSig XPatSynSig GhcRn
_ [LIdP GhcRn]
names LHsSigType GhcRn
_) -> RhsNames -> [Name] -> RhsNames
extendNameSetList RhsNames
ns (forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [LIdP GhcRn]
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 { TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let
env' :: TcGblEnv
env' = TcGblEnv
env { tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [LRuleDecl GhcTc]
lcl_rules forall a. [a] -> [a] -> [a]
++ TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
env }
; forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' TcM a
thing_inside }
checkWellStaged :: SDoc
-> ThLevel
-> ThLevel
-> TcM ()
checkWellStaged :: SDoc -> ThLevel -> ThLevel -> TcRn ()
checkWellStaged SDoc
pp_thing ThLevel
bind_lvl ThLevel
use_lvl
| ThLevel
use_lvl forall a. Ord a => a -> a -> Bool
>= ThLevel
bind_lvl
= forall (m :: * -> *) a. Monad m => a -> m a
return ()
| ThLevel
bind_lvl forall a. Eq a => a -> a -> Bool
== ThLevel
outerLevel
= forall a. SDoc -> TcM a
stageRestrictionError SDoc
pp_thing
| Bool
otherwise
= forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"Stage error:" SDoc -> SDoc -> SDoc
<+> SDoc
pp_thing SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
hsep [String -> SDoc
text String
"is bound at stage" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
bind_lvl,
String -> SDoc
text String
"but used at stage" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr ThLevel
use_lvl]
stageRestrictionError :: SDoc -> TcM a
stageRestrictionError :: forall a. SDoc -> TcM a
stageRestrictionError SDoc
pp_thing
= forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ String -> SDoc
text String
"GHC stage restriction:"
, ThLevel -> SDoc -> SDoc
nest ThLevel
2 ([SDoc] -> SDoc
vcat [ SDoc
pp_thing SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is used in a top-level splice, quasi-quote, or annotation,"
, String -> SDoc
text String
"and must be imported, not defined locally"])]
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 -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcMetaTy Name
tc_name = do
TyCon
t <- Name -> TcM TyCon
tcLookupTyCon Name
tc_name
forall (m :: * -> *) a. Monad m => a -> m a
return (TyCon -> Type
mkTyConTy TyCon
t)
isBrackStage :: ThStage -> Bool
isBrackStage :: ThStage -> Bool
isBrackStage (Brack {}) = Bool
True
isBrackStage ThStage
_other = Bool
False
tcGetDefaultTys :: TcM ([Type],
(Bool,
Bool))
tcGetDefaultTys :: TcM ([Type], (Bool, Bool))
tcGetDefaultTys
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let ovl_strings :: Bool
ovl_strings = Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverloadedStrings DynFlags
dflags
extended_defaults :: Bool
extended_defaults = Extension -> DynFlags -> Bool
xopt Extension
LangExt.ExtendedDefaultRules DynFlags
dflags
flags :: (Bool, Bool)
flags = (Bool
ovl_strings, Bool
extended_defaults)
; Maybe [Type]
mb_defaults <- TcRn (Maybe [Type])
getDeclaredDefaultTys
; case Maybe [Type]
mb_defaults of {
Just [Type]
tys -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
tys, (Bool, Bool)
flags) ;
Maybe [Type]
Nothing -> do
{ Type
integer_ty <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcMetaTy Name
integerTyConName
; Type
list_ty <- Name -> IOEnv (Env TcGblEnv TcLclEnv) Type
tcMetaTy Name
listTyConName
; TyCon -> TcRn ()
checkWiredInTyCon TyCon
doubleTyCon
; let deflt_tys :: [Type]
deflt_tys = forall {a}. Bool -> [a] -> [a]
opt_deflt Bool
extended_defaults [Type
unitTy, Type
list_ty]
forall a. [a] -> [a] -> [a]
++ [Type
integer_ty, Type
doubleTy]
forall a. [a] -> [a] -> [a]
++ forall {a}. Bool -> [a] -> [a]
opt_deflt Bool
ovl_strings [Type
stringTy]
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
deflt_tys, (Bool, Bool)
flags) } } }
where
opt_deflt :: Bool -> [a] -> [a]
opt_deflt Bool
True [a]
xs = [a]
xs
opt_deflt Bool
False [a]
_ = []
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 (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 = 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 (forall a. InstInfo a -> ClsInst
iSpec InstInfo (GhcPass a)
info) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"where")
ThLevel
2 (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 (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 (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 (forall a. InstInfo a -> ClsInst
iSpec InstInfo a
info) of
([Id]
_, Class
cls, [Type
ty]) -> (Class
cls, Type
ty)
([Id], Class, [Type])
_ -> forall a. String -> a
panic String
"simpleInstInfoClsTy"
simpleInstInfoTy :: InstInfo a -> Type
simpleInstInfoTy :: forall a. InstInfo a -> Type
simpleInstInfoTy InstInfo a
info = forall a b. (a, b) -> b
snd (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 (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 { Bool
is_boot <- TcM Bool
tcIsHsBootOrSig
; Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; let info_string :: String
info_string = OccName -> String
occNameString (forall a. NamedThing a => a -> OccName
getOccName Class
clas) forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OccName -> String
occNameStringforall b c a. (b -> c) -> (a -> b) -> a -> c
.Type -> OccName
getDFunTyKey) [Type]
tys
; OccName
dfun_occ <- (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc (String -> Bool -> OccSet -> OccName
mkDFunOcc String
info_string Bool
is_boot)
; forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
dfun_occ SrcSpan
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 forall a. a -> a
id (forall a. SrcSpanAnn' 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 (forall a. SrcSpanAnn' 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 { Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
; let info_string :: String
info_string = OccName -> String
occNameString (forall a. NamedThing a => a -> OccName
getOccName Name
tc_name) forall a. [a] -> [a] -> [a]
++
forall a. [a] -> [[a]] -> [a]
intercalate String
"|" [String]
ty_strings
; OccName
occ <- (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc (String -> OccSet -> OccName
mkInstTyTcOcc String
info_string)
; forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod (OccName -> OccName
adaptOcc OccName
occ) SrcSpan
loc }
where
ty_strings :: [String]
ty_strings = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (OccName -> String
occNameString 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
Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
FastString
name <- forall (m :: * -> *).
(MonadIO m, HasDynFlags m, HasModule m) =>
String -> String -> m FastString
mkWrapperName String
"stable" String
str
let occ :: OccName
occ = FastString -> OccName
mkVarOccFS FastString
name :: OccName
gnm :: Name
gnm = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod (OccName -> OccName
occ_wrapper OccName
occ) SrcSpan
loc :: Name
id :: Id
id = Name -> Type -> Id
mkExportedVanillaId Name
gnm Type
sig_ty :: Id
forall (m :: * -> *) a. Monad m => a -> m a
return Id
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 (forall a. NamedThing a => a -> String
getOccString Name
nm)
mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)
=> String -> String -> m FastString
mkWrapperName :: forall (m :: * -> *).
(MonadIO m, HasDynFlags m, HasModule m) =>
String -> String -> m FastString
mkWrapperName String
what String
nameBase
= do DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Module
thisMod <- forall (m :: * -> *). HasModule m => m Module
getModule
let
wrapperRef :: IORef (ModuleEnv ThLevel)
wrapperRef = DynFlags -> IORef (ModuleEnv ThLevel)
nextWrapperNum DynFlags
dflags
pkg :: String
pkg = forall u. IsUnitId u => u -> String
unitString (forall unit. GenModule unit -> unit
moduleUnit Module
thisMod)
mod :: String
mod = ModuleName -> String
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName Module
thisMod)
ThLevel
wrapperNum <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (ModuleEnv ThLevel)
wrapperRef forall a b. (a -> b) -> a -> b
$ \ModuleEnv ThLevel
mod_env ->
let num :: ThLevel
num = forall a. ModuleEnv a -> a -> Module -> a
lookupWithDefaultModuleEnv ModuleEnv ThLevel
mod_env ThLevel
0 Module
thisMod
mod_env' :: ModuleEnv ThLevel
mod_env' = forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv ThLevel
mod_env Module
thisMod (ThLevel
numforall a. Num a => a -> a -> a
+ThLevel
1)
in (ModuleEnv ThLevel
mod_env', ThLevel
num)
let components :: [String]
components = [String
what, forall a. Show a => a -> String
show ThLevel
wrapperNum, String
pkg, String
mod, String
nameBase]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
":" [String]
components
pprBinders :: [Name] -> SDoc
pprBinders :: [Name] -> SDoc
pprBinders [Name
bndr] = SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
bndr)
pprBinders [Name]
bndrs = forall a. (a -> SDoc) -> [a] -> SDoc
pprWithCommas forall a. Outputable a => a -> SDoc
ppr [Name]
bndrs
notFound :: Name -> TcM TyThing
notFound :: Name -> TcM TyThing
notFound Name
name
= do { TcLclEnv
lcl_env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let stage :: ThStage
stage = TcLclEnv -> ThStage
tcl_th_ctxt TcLclEnv
lcl_env
; case ThStage
stage of
Splice {}
| Name -> Bool
isUnboundName Name
name -> forall env a. IOEnv env a
failM
| Bool
otherwise -> forall a. SDoc -> TcM a
stageRestrictionError (SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name))
ThStage
_ -> forall a. SDoc -> TcM a
failWithTc forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
vcat[String -> SDoc
text String
"GHC internal error:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"is not in scope during type checking, but it passed the renamer",
String -> SDoc
text String
"tcl_env of environment:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (TcLclEnv -> TcTypeEnv
tcl_env TcLclEnv
lcl_env)]
}
wrongThingErr :: String -> TcTyThing -> Name -> TcM a
wrongThingErr :: forall a. String -> TcTyThing -> Name -> TcM a
wrongThingErr String
expected TcTyThing
thing Name
name
= forall a. SDoc -> TcM a
failWithTc (TcTyThing -> SDoc
pprTcTyThingCategory TcTyThing
thing SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"used as a" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
expected)