module IfaceEnv (
newGlobalBinder, newInteractiveBinder,
externaliseName,
lookupIfaceTop,
lookupOrig, lookupOrigNameCache, extendNameCache,
newIfaceName, newIfaceNames,
extendIfaceIdEnv, extendIfaceTyVarEnv,
tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,
lookupIfaceTyVar, extendIfaceEnvs,
ifaceExportNames,
allocateGlobalBinder,
initNameCache, updNameCache,
mkNameCacheUpdater, NameCacheUpdater(..)
) where
#include "HsVersions.h"
import TcRnMonad
import TysWiredIn
import HscTypes
import Type
import Var
import Name
import Avail
import Module
import UniqFM
import FastString
import IfaceType
import UniqSupply
import SrcLoc
import Util
import Outputable
import Data.List ( partition )
newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder mod occ loc
= do { mod `seq` occ `seq` return ()
; name <- updNameCache $ \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 $ \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
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig mod occ
= do {
mod `seq` occ `seq` return ()
; updNameCache $ \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 ()
; updNameCache $ \ ns ->
let name' = mkExternalName uniq mod occ loc
ns' = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }
in (ns', name') }
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache nc mod occ
| Just name <- isBuiltInOcc_maybe occ
=
Just name
| otherwise
= case lookupModuleEnv nc mod of
Nothing -> Nothing
Just occ_env -> lookupOccEnv occ_env occ
extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache nc name
= ASSERT2( isExternalName name, ppr name )
extendNameCache nc (nameModule name) (nameOccName name) name
extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendNameCache nc mod occ name
= extendModuleEnvWith combine nc mod (unitOccEnv occ name)
where
combine _ occ_env = extendOccEnv occ_env occ name
updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
updNameCache upd_fn = do { hsc_env <- getTopEnv
; liftIO $ updNameCacheIO hsc_env upd_fn }
newtype NameCacheUpdater
= NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do { hsc_env <- getTopEnv
; return (NCU (updNameCacheIO hsc_env)) }
initNameCache :: UniqSupply -> [Name] -> NameCache
initNameCache us names
= NameCache { nsUniqs = us,
nsNames = initOrigNames names }
initOrigNames :: [Name] -> OrigNameCache
initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId occ
= do { lcl <- getLclEnv
; case (lookupUFM (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' = addListToUFM (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 (lookupUFM (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 (lookupUFM (if_tv_env lcl) occ) }
lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar (IfaceIdBndr (occ, _))
= do { lcl <- getLclEnv
; return (lookupUFM (if_id_env lcl) occ) }
lookupIfaceVar (IfaceTvBndr (occ, _))
= do { lcl <- getLclEnv
; return (lookupUFM (if_tv_env lcl) occ) }
extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv tyvars thing_inside
= do { env <- getLclEnv
; let { tv_env' = addListToUFM (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] }