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.Session
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 GHC.Utils.Error
import GHC.Utils.Logger
import Data.List ( partition )
import Control.Monad
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder mod occ loc
= do { hsc_env <- 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 hsc_env occ loc = do
let mod = icInteractiveModule (hsc_IC hsc_env)
allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
allocateGlobalBinder
:: NameCache
-> Module -> OccName -> SrcSpan
-> IO Name
allocateGlobalBinder nc mod occ loc
= updateNameCache nc mod occ $ \cache0 -> do
case lookupOrigNameCache cache0 mod occ of
Just name | isWiredInName name
-> pure (cache0, name)
| otherwise
-> pure (new_cache, name')
where
uniq = nameUnique name
name' = mkExternalName uniq mod occ loc
new_cache = extendOrigNameCache cache0 mod occ name'
_ -> do
uniq <- takeUniqFromNameCache nc
let name = mkExternalName uniq mod occ loc
let new_cache = extendOrigNameCache cache0 mod occ name
pure (new_cache, name)
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames exports = return exports
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ = do
hsc_env <- getTopEnv
traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
liftIO $ lookupNameCache (hsc_NC hsc_env) mod occ
lookupNameCache :: NameCache -> Module -> OccName -> IO Name
lookupNameCache nc mod occ = updateNameCache nc mod occ $ \cache0 ->
case lookupOrigNameCache cache0 mod occ of
Just name -> pure (cache0, name)
Nothing -> do
uniq <- takeUniqFromNameCache nc
let name = mkExternalName uniq mod occ noSrcSpan
let new_cache = extendOrigNameCache cache0 mod occ name
pure (new_cache, name)
externaliseName :: Module -> Name -> TcRnIf m n Name
externaliseName mod name
= do { let occ = nameOccName name
loc = nameSrcSpan name
uniq = nameUnique name
; occ `seq` return ()
; hsc_env <- getTopEnv
; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \cache -> do
let name' = mkExternalName uniq mod occ loc
cache' = extendOrigNameCache cache mod occ name'
pure (cache', name') }
setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
setNameModule Nothing n = return n
setNameModule (Just m) n =
newGlobalBinder m (nameOccName n) (nameSrcSpan n)
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
; case (lookupFsEnv (if_id_env lcl) occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface id out of scope: " <+> ppr occ)
}
extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv ids
= updLclEnv $ \env ->
let { id_env' = extendFsEnvList (if_id_env env) pairs
; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
in env { if_id_env = id_env' }
tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar occ
= do { lcl <- getLclEnv
; case (lookupFsEnv (if_tv_env lcl) occ) of
Just ty_var -> return ty_var
Nothing -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)
}
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar (occ, _)
= do { lcl <- getLclEnv
; return (lookupFsEnv (if_tv_env lcl) occ) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar (IfaceIdBndr (_, occ, _))
= do { lcl <- getLclEnv
; return (lookupFsEnv (if_id_env lcl) occ) }
lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
; return (lookupFsEnv (if_tv_env lcl) occ) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars
= updLclEnv $ \env ->
let { tv_env' = extendFsEnvList (if_tv_env env) pairs
; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
in env { if_tv_env = tv_env' }
extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs tcvs thing_inside
= extendIfaceTyVarEnv tvs $
extendIfaceIdEnv cvs $
thing_inside
where
(tvs, cvs) = partition isTyVar tcvs
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop occ
= do { env <- getLclEnv; lookupOrig (if_mod env) occ }
newIfaceName :: OccName -> IfL Name
newIfaceName occ
= do { uniq <- newUnique
; return $! mkInternalName uniq occ noSrcSpan }
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames occs
= do { uniqs <- newUniqueSupply
; return [ mkInternalName uniq occ noSrcSpan
| (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
trace_if :: Logger -> SDoc -> IO ()
trace_if logger doc = when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger doc
trace_hi_diffs :: Logger -> SDoc -> IO ()
trace_hi_diffs logger doc = when (logHasDumpFlag logger Opt_D_dump_hi_diffs) $ putMsg logger doc