module IfaceEnv (
newGlobalBinder, newInteractiveBinder,
externaliseName,
lookupIfaceTop,
lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
lookupIfaceTyVar, extendIfaceEnvs,
setNameModule,
ifaceExportNames,
allocateGlobalBinder, updNameCacheTc,
mkNameCacheUpdater, NameCacheUpdater(..),
) where
#include "HsVersions.h"
import GhcPrelude
import TcRnMonad
import HscTypes
import Type
import Var
import Name
import Avail
import Module
import FastString
import FastStringEnv
import IfaceType
import NameCache
import UniqSupply
import SrcLoc
import Outputable
import Data.List ( partition )
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder mod occ loc
= do { name <- updNameCacheTc mod occ $ \name_cache ->
allocateGlobalBinder name_cache 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)
; updNameCacheIO hsc_env mod occ $ \name_cache ->
allocateGlobalBinder name_cache mod occ loc }
allocateGlobalBinder
:: NameCache
-> Module -> OccName -> SrcSpan
-> (NameCache, Name)
allocateGlobalBinder name_supply mod occ loc
= case lookupOrigNameCache (nsNames name_supply) mod occ of
Just name | isWiredInName name
-> (name_supply, name)
| otherwise
-> (new_name_supply, name')
where
uniq = nameUnique name
name' = mkExternalName uniq mod occ loc
new_cache = extendNameCache (nsNames name_supply) mod occ name'
new_name_supply = name_supply {nsNames = new_cache}
_ -> (new_name_supply, name)
where
(uniq, us') = takeUniqFromSupply (nsUniqs name_supply)
name = mkExternalName uniq mod occ loc
new_cache = extendNameCache (nsNames name_supply) mod occ name
new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}
ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames exports = return exports
newtype NameCacheUpdater
= NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { hsc_env <- getTopEnv
; return (NCU (updNameCache hsc_env)) }
updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))
-> TcRnIf a b c
updNameCacheTc mod occ upd_fn = do {
hsc_env <- getTopEnv
; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }
updNameCacheIO :: HscEnv -> Module -> OccName
-> (NameCache -> (NameCache, c))
-> IO c
updNameCacheIO hsc_env mod occ upd_fn = do {
mod `seq` occ `seq` return ()
; updNameCache hsc_env upd_fn }
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ
= do { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
; updNameCacheTc mod occ $ lookupNameCache mod occ }
lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name
lookupOrigIO hsc_env mod occ
= updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ
lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)
lookupNameCache mod occ name_cache =
case lookupOrigNameCache (nsNames name_cache) mod occ of {
Just name -> (name_cache, name);
Nothing ->
case takeUniqFromSupply (nsUniqs name_cache) of {
(uniq, us) ->
let
name = mkExternalName uniq mod occ noSrcSpan
new_cache = extendNameCache (nsNames name_cache) mod occ name
in (name_cache{ nsUniqs = us, nsNames = 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 ()
; updNameCacheTc mod occ $ \ ns ->
let name' = mkExternalName uniq mod occ loc
ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
in (ns', 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 thing_inside
= do { env <- getLclEnv
; let { id_env' = extendFsEnvList (if_id_env env) pairs
; pairs = [(occNameFS (getOccName id), id) | id <- ids] }
; setLclEnv (env { if_id_env = id_env' }) thing_inside }
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 thing_inside
= do { env <- getLclEnv
; let { tv_env' = extendFsEnvList (if_tv_env env) pairs
; pairs = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }
; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }
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] }