{-# LANGUAGE RankNTypes #-}
module GHC.Iface.Env (
newGlobalBinder, newInteractiveBinder,
externaliseName,
lookupIfaceTop,
lookupOrig, lookupNameCache, lookupOrigNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
lookupIfaceTyVar, extendIfaceEnvs,
setNameModule,
ifaceExportNames,
trace_if, trace_hi_diffs,
allocateGlobalBinder,
) where
import GHC.Prelude
import GHC.Driver.Env
import GHC.Driver.DynFlags
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.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 GHC.Utils.Error
import GHC.Utils.Logger
import Data.List ( partition )
import Control.Monad
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 { hsc_env <- TcRnIf a b HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
; traceIf (text "newGlobalBinder" <+>
(vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
; return 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)
NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) Module
mod OccName
occ SrcSpan
loc
allocateGlobalBinder
:: NameCache
-> Module -> OccName -> SrcSpan
-> IO Name
allocateGlobalBinder :: NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder NameCache
nc Module
mod OccName
occ SrcSpan
loc
= NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, Name))
-> IO Name
forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ ((OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name)
-> (OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name
forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache0 -> do
case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ of
Just Name
name | Name -> Bool
isWiredInName Name
name
-> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache0, Name
name)
| Bool
otherwise
-> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
new_cache, 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
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name'
Maybe Name
_ -> do
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
let name = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
let new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name
pure (new_cache, name)
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames :: forall gbl lcl. [IfaceExport] -> TcRnIf gbl lcl [IfaceExport]
ifaceExportNames [IfaceExport]
exports = [IfaceExport] -> IOEnv (Env gbl lcl) [IfaceExport]
forall a. a -> IOEnv (Env gbl lcl) a
forall (m :: * -> *) a. Monad m => a -> m a
return [IfaceExport]
exports
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig :: forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig Module
mod OccName
occ = do
hsc_env <- TcRnIf a b HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ
lookupNameCache :: NameCache -> Module -> OccName -> IO Name
lookupNameCache :: NameCache -> Module -> OccName -> IO Name
lookupNameCache NameCache
nc Module
mod OccName
occ = NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, Name))
-> IO Name
forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ ((OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name)
-> (OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name
forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache0 ->
case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ of
Just Name
name -> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache0, Name
name)
Maybe Name
Nothing -> do
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
let name = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
noSrcSpan
let new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name
pure (new_cache, 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 OccName -> IOEnv (Env m n) () -> IOEnv (Env m n) ()
forall a b. a -> b -> b
`seq` () -> IOEnv (Env m n) ()
forall a. a -> IOEnv (Env m n) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; hsc_env <- TcRnIf m n HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \OrigNameCache
cache -> do
let name' :: Name
name' = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
cache' :: OrigNameCache
cache' = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache Module
mod OccName
occ Name
name'
(OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache', 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 = Name -> IOEnv (Env m n) Name
forall a. a -> IOEnv (Env m n) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
setNameModule (Just Module
m) Name
n =
Module -> OccName -> SrcSpan -> IOEnv (Env m n) Name
forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
m (Name -> OccName
nameOccName Name
n) (Name -> SrcSpan
nameSrcSpan Name
n)
tcIfaceLclId :: IfLclName -> IfL Id
tcIfaceLclId :: IfLclName -> IfL Id
tcIfaceLclId IfLclName
occ
= do { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; case lookupFsEnv (if_id_env lcl) (ifLclNameFS occ) of
Just Id
ty_var -> Id -> IfL Id
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
Maybe Id
Nothing -> SDoc -> IfL Id
forall a. SDoc -> IfL a
failIfM (SDoc -> IfL Id) -> SDoc -> IfL Id
forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iface id out of scope: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IfLclName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfLclName
occ
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"env:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastStringEnv Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
lcl) ]
}
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv :: forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
ids
= (IfLclEnv -> IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv a -> TcRnIf IfGblEnv IfLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((IfLclEnv -> IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv a -> TcRnIf IfGblEnv IfLclEnv a)
-> (IfLclEnv -> IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv a
-> TcRnIf IfGblEnv IfLclEnv a
forall a b. (a -> b) -> a -> b
$ \IfLclEnv
env ->
let { id_env' :: FastStringEnv Id
id_env' = FastStringEnv Id -> [(FastString, Id)] -> FastStringEnv Id
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 (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
id), Id
id) | Id
id <- [Id]
ids] }
in IfLclEnv
env { if_id_env = id_env' }
tcIfaceTyVar :: IfLclName -> IfL TyVar
tcIfaceTyVar :: IfLclName -> IfL Id
tcIfaceTyVar IfLclName
occ
= do { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; case lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ) of
Just Id
ty_var -> Id -> IfL Id
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
Maybe Id
Nothing -> SDoc -> IfL Id
forall a. SDoc -> IfL a
failIfM (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iface type variable out of scope: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> IfLclName -> SDoc
forall a. Outputable a => a -> SDoc
ppr IfLclName
occ)
}
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe Id)
lookupIfaceTyVar (IfLclName
occ, IfaceKind
_)
= do { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar :: IfaceBndr -> IfL (Maybe Id)
lookupIfaceVar (IfaceIdBndr (IfaceKind
_, IfLclName
occ, IfaceKind
_))
= do { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; return (lookupFsEnv (if_id_env lcl) (ifLclNameFS occ)) }
lookupIfaceVar (IfaceTvBndr (IfLclName
occ, IfaceKind
_))
= do { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
; return (lookupFsEnv (if_tv_env lcl) (ifLclNameFS occ)) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv :: forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tyvars
= (IfLclEnv -> IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv a -> TcRnIf IfGblEnv IfLclEnv a
forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv ((IfLclEnv -> IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv a -> TcRnIf IfGblEnv IfLclEnv a)
-> (IfLclEnv -> IfLclEnv)
-> TcRnIf IfGblEnv IfLclEnv a
-> TcRnIf IfGblEnv IfLclEnv a
forall a b. (a -> b) -> a -> b
$ \IfLclEnv
env ->
let { tv_env' :: FastStringEnv Id
tv_env' = FastStringEnv Id -> [(FastString, Id)] -> FastStringEnv Id
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 (Id -> OccName
forall a. NamedThing a => a -> OccName
getOccName Id
tv), Id
tv) | Id
tv <- [Id]
tyvars] }
in IfLclEnv
env { if_tv_env = tv_env' }
extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs :: forall a. [Id] -> IfL a -> IfL a
extendIfaceEnvs [Id]
tcvs IfL a
thing_inside
= [Id] -> IfL a -> IfL a
forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tvs (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
[Id] -> IfL a -> IfL a
forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
cvs (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
IfL a
thing_inside
where
([Id]
tvs, [Id]
cvs) = (Id -> Bool) -> [Id] -> ([Id], [Id])
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 { env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; lookupOrig (if_mod env) occ }
newIfaceName :: OccName -> IfL Name
newIfaceName :: OccName -> IfL Name
newIfaceName OccName
occ
= do { uniq <- TcRnIf IfGblEnv IfLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; return $! mkInternalName uniq occ noSrcSpan }
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames [OccName]
occs
= do { uniqs <- IOEnv (Env IfGblEnv IfLclEnv) [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
; return [ mkInternalName uniq occ noSrcSpan
| (occ,uniq) <- occs `zip` uniqs] }
trace_if :: Logger -> SDoc -> IO ()
{-# INLINE trace_if #-}
trace_if :: Logger -> SDoc -> IO ()
trace_if Logger
logger SDoc
doc = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
doc
trace_hi_diffs :: Logger -> SDoc -> IO ()
{-# INLINE trace_hi_diffs #-}
trace_hi_diffs :: Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger SDoc
doc = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_hi_diffs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
doc