{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}
module GHC.Iface.Env (
newGlobalBinder, newInteractiveBinder,
externaliseName,
lookupIfaceTop,
lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
lookupIfaceTyVar, extendIfaceEnvs,
setNameModule,
ifaceExportNames,
allocateGlobalBinder, updNameCacheTc, updNameCache,
mkNameCacheUpdater, NameCacheUpdater(..),
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Env
import GHC.Tc.Utils.Monad
import GHC.Core.Type
import GHC.Iface.Type
import GHC.Runtime.Context
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Data.FastString
import GHC.Data.FastString.Env
import GHC.Types.Var
import GHC.Types.Name
import GHC.Types.Avail
import GHC.Types.Name.Cache
import GHC.Types.Unique.Supply
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import Data.List ( partition )
import Data.IORef
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder :: forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
loc
= do { Name
name <- forall c a b.
Module -> OccName -> (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCacheTc Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ \NameCache
name_cache ->
NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name)
allocateGlobalBinder NameCache
name_cache Module
mod OccName
occ SrcSpan
loc
; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"newGlobalBinder" SDoc -> SDoc -> SDoc
<+>
([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr OccName
occ SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc, forall a. Outputable a => a -> SDoc
ppr Name
name]))
; forall (m :: * -> *) a. Monad m => a -> m a
return Name
name }
newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
occ SrcSpan
loc
= do { let mod :: Module
mod = InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
; forall c.
HscEnv
-> Module -> OccName -> (NameCache -> (NameCache, c)) -> IO c
updNameCacheIO HscEnv
hsc_env Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ \NameCache
name_cache ->
NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name)
allocateGlobalBinder NameCache
name_cache Module
mod OccName
occ SrcSpan
loc }
allocateGlobalBinder
:: NameCache
-> Module -> OccName -> SrcSpan
-> (NameCache, Name)
allocateGlobalBinder :: NameCache -> Module -> OccName -> SrcSpan -> (NameCache, Name)
allocateGlobalBinder NameCache
name_supply Module
mod OccName
occ SrcSpan
loc
= case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_supply) Module
mod OccName
occ of
Just Name
name | Name -> Bool
isWiredInName Name
name
-> (NameCache
name_supply, Name
name)
| Bool
otherwise
-> (NameCache
new_name_supply, Name
name')
where
uniq :: Unique
uniq = Name -> Unique
nameUnique Name
name
name' :: Name
name' = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_supply) Module
mod OccName
occ Name
name'
new_name_supply :: NameCache
new_name_supply = NameCache
name_supply {nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache}
Maybe Name
_ -> (NameCache
new_name_supply, Name
name)
where
(Unique
uniq, UniqSupply
us') = UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
name_supply)
name :: Name
name = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_supply) Module
mod OccName
occ Name
name
new_name_supply :: NameCache
new_name_supply = NameCache
name_supply {nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us', nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache}
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames :: forall gbl lcl. [IfaceExport] -> TcRnIf gbl lcl [IfaceExport]
ifaceExportNames [IfaceExport]
exports = forall (m :: * -> *) a. Monad m => a -> m a
return [IfaceExport]
exports
newtype NameCacheUpdater
= NCU { NameCacheUpdater -> forall c. (NameCache -> (NameCache, c)) -> IO c
updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater :: forall a b. TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; let !ncRef :: IORef NameCache
ncRef = HscEnv -> IORef NameCache
hsc_NC HscEnv
hsc_env
; forall (m :: * -> *) a. Monad m => a -> m a
return ((forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU (forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
updNameCache IORef NameCache
ncRef)) }
updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
-> TcRnIf a b c
updNameCacheTc :: forall c a b.
Module -> OccName -> (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCacheTc Module
mod OccName
occ NameCache -> (NameCache, c)
upd_fn = do {
HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c.
HscEnv
-> Module -> OccName -> (NameCache -> (NameCache, c)) -> IO c
updNameCacheIO HscEnv
hsc_env Module
mod OccName
occ NameCache -> (NameCache, c)
upd_fn }
updNameCacheIO :: HscEnv -> Module -> OccName
-> (NameCache -> (NameCache, c))
-> IO c
updNameCacheIO :: forall c.
HscEnv
-> Module -> OccName -> (NameCache -> (NameCache, c)) -> IO c
updNameCacheIO HscEnv
hsc_env Module
mod OccName
occ NameCache -> (NameCache, c)
upd_fn = do {
Module
mod seq :: forall a b. a -> b -> b
`seq` OccName
occ seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
; forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
updNameCache (HscEnv -> IORef NameCache
hsc_NC HscEnv
hsc_env) NameCache -> (NameCache, c)
upd_fn }
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig :: forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig Module
mod OccName
occ
= do { forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"lookup_orig" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr OccName
occ)
; forall c a b.
Module -> OccName -> (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCacheTc Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ Module -> OccName -> NameCache -> (NameCache, Name)
lookupNameCache Module
mod OccName
occ }
lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO HscEnv
hsc_env Module
mod OccName
occ
= forall c.
HscEnv
-> Module -> OccName -> (NameCache -> (NameCache, c)) -> IO c
updNameCacheIO HscEnv
hsc_env Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ Module -> OccName -> NameCache -> (NameCache, Name)
lookupNameCache Module
mod OccName
occ
lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
lookupNameCache Module
mod OccName
occ NameCache
name_cache =
case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_cache) Module
mod OccName
occ of {
Just Name
name -> (NameCache
name_cache, Name
name);
Maybe Name
Nothing ->
case UniqSupply -> (Unique, UniqSupply)
takeUniqFromSupply (NameCache -> UniqSupply
nsUniqs NameCache
name_cache) of {
(Unique
uniq, UniqSupply
us) ->
let
name :: Name
name = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
noSrcSpan
new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache (NameCache -> OrigNameCache
nsNames NameCache
name_cache) Module
mod OccName
occ Name
name
in (NameCache
name_cache{ nsUniqs :: UniqSupply
nsUniqs = UniqSupply
us, nsNames :: OrigNameCache
nsNames = OrigNameCache
new_cache }, Name
name) }}
externaliseName :: Module -> Name -> TcRnIf m n Name
externaliseName :: forall m n. Module -> Name -> TcRnIf m n Name
externaliseName Module
mod Name
name
= do { let occ :: OccName
occ = Name -> OccName
nameOccName Name
name
loc :: SrcSpan
loc = Name -> SrcSpan
nameSrcSpan Name
name
uniq :: Unique
uniq = Name -> Unique
nameUnique Name
name
; OccName
occ seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()
; forall c a b.
Module -> OccName -> (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCacheTc Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ \ NameCache
ns ->
let name' :: Name
name' = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
ns' :: NameCache
ns' = NameCache
ns { nsNames :: OrigNameCache
nsNames = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache (NameCache -> OrigNameCache
nsNames NameCache
ns) Module
mod OccName
occ Name
name' }
in (NameCache
ns', Name
name') }
setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
setNameModule :: forall m n. Maybe Module -> Name -> TcRnIf m n Name
setNameModule Maybe Module
Nothing Name
n = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
setNameModule (Just Module
m) Name
n =
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
m (Name -> OccName
nameOccName Name
n) (Name -> SrcSpan
nameSrcSpan Name
n)
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId FastString
occ
= do { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; case (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
lcl) FastString
occ) of
Just Id
ty_var -> forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
Maybe Id
Nothing -> forall a. SDoc -> IfL a
failIfM (String -> SDoc
text String
"Iface id out of scope: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr FastString
occ)
}
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv :: forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
ids IfL a
thing_inside
= do { IfLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let { id_env' :: FastStringEnv Id
id_env' = forall a. FastStringEnv a -> [(FastString, a)] -> FastStringEnv a
extendFsEnvList (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
env) [(FastString, Id)]
pairs
; pairs :: [(FastString, Id)]
pairs = [(OccName -> FastString
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
id), Id
id) | Id
id <- [Id]
ids] }
; forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (IfLclEnv
env { if_id_env :: FastStringEnv Id
if_id_env = FastStringEnv Id
id_env' }) IfL a
thing_inside }
tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar :: FastString -> IfL Id
tcIfaceTyVar FastString
occ
= do { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; case (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
lcl) FastString
occ) of
Just Id
ty_var -> forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
Maybe Id
Nothing -> forall a. SDoc -> IfL a
failIfM (String -> SDoc
text String
"Iface type variable out of scope: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr FastString
occ)
}
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe Id)
lookupIfaceTyVar (FastString
occ, IfaceKind
_)
= do { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
lcl) FastString
occ) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar :: IfaceBndr -> IfL (Maybe Id)
lookupIfaceVar (IfaceIdBndr (IfaceKind
_, FastString
occ, IfaceKind
_))
= do { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
lcl) FastString
occ) }
lookupIfaceVar (IfaceTvBndr (FastString
occ, IfaceKind
_))
= do { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
lcl) FastString
occ) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv :: forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tyvars IfL a
thing_inside
= do { IfLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; let { tv_env' :: FastStringEnv Id
tv_env' = forall a. FastStringEnv a -> [(FastString, a)] -> FastStringEnv a
extendFsEnvList (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
env) [(FastString, Id)]
pairs
; pairs :: [(FastString, Id)]
pairs = [(OccName -> FastString
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
tv), Id
tv) | Id
tv <- [Id]
tyvars] }
; forall lcl' gbl a lcl.
lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a
setLclEnv (IfLclEnv
env { if_tv_env :: FastStringEnv Id
if_tv_env = FastStringEnv Id
tv_env' }) IfL a
thing_inside }
extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs :: forall a. [Id] -> IfL a -> IfL a
extendIfaceEnvs [Id]
tcvs IfL a
thing_inside
= forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tvs forall a b. (a -> b) -> a -> b
$
forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
cvs forall a b. (a -> b) -> a -> b
$
IfL a
thing_inside
where
([Id]
tvs, [Id]
cvs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
tcvs
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop OccName
occ
= do { IfLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig (IfLclEnv -> Module
if_mod IfLclEnv
env) OccName
occ }
newIfaceName :: OccName -> IfL Name
newIfaceName :: OccName -> IfL Name
newIfaceName OccName
occ
= do { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
noSrcSpan }
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames [OccName]
occs
= do { UniqSupply
uniqs <- forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
; forall (m :: * -> *) a. Monad m => a -> m a
return [ Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
noSrcSpan
| (OccName
occ,Unique
uniq) <- [OccName]
occs forall a b. [a] -> [b] -> [(a, b)]
`zip` UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
uniqs] }
updNameCache :: IORef NameCache
-> (NameCache -> (NameCache, c))
-> IO c
updNameCache :: forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
updNameCache IORef NameCache
ncRef NameCache -> (NameCache, c)
upd_fn
= forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef NameCache
ncRef NameCache -> (NameCache, c)
upd_fn