{-# LANGUAGE RankNTypes #-}
module GHC.Types.Name.Cache
( NameCache (..)
, initNameCache
, takeUniqFromNameCache
, updateNameCache'
, updateNameCache
, OrigNameCache
, lookupOrigNameCache
, extendOrigNameCache'
, extendOrigNameCache
)
where
import GHC.Prelude
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Types.Unique.Supply
import GHC.Builtin.Types
import GHC.Builtin.Names
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Concurrent.MVar
import Control.Monad
data NameCache = NameCache
{ NameCache -> Char
nsUniqChar :: {-# UNPACK #-} !Char
, NameCache -> MVar OrigNameCache
nsNames :: {-# UNPACK #-} !(MVar OrigNameCache)
}
type OrigNameCache = ModuleEnv (OccEnv Name)
takeUniqFromNameCache :: NameCache -> IO Unique
takeUniqFromNameCache :: NameCache -> IO Unique
takeUniqFromNameCache (NameCache Char
c MVar OrigNameCache
_) = Char -> IO Unique
uniqFromMask Char
c
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
nc Module
mod OccName
occ
| Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_TYPES Bool -> Bool -> Bool
|| Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_PRIM Bool -> Bool -> Bool
|| Module
mod Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
gHC_TUPLE_PRIM
, Just Name
name <- OccName -> Maybe Name
isBuiltInOcc_maybe OccName
occ
=
Name -> Maybe Name
forall a. a -> Maybe a
Just Name
name
| Bool
otherwise
= case OrigNameCache -> Module -> Maybe (OccEnv Name)
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv OrigNameCache
nc Module
mod of
Maybe (OccEnv Name)
Nothing -> Maybe Name
forall a. Maybe a
Nothing
Just OccEnv Name
occ_env -> OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv Name
occ_env OccName
occ
extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache' :: OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache' OrigNameCache
nc Name
name
= Bool -> SDoc -> OrigNameCache -> OrigNameCache
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Name -> Bool
isExternalName Name
name) (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) (OrigNameCache -> OrigNameCache) -> OrigNameCache -> OrigNameCache
forall a b. (a -> b) -> a -> b
$
OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
nc ((() :: Constraint) => Name -> Module
Name -> Module
nameModule Name
name) (Name -> OccName
nameOccName Name
name) Name
name
extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
nc Module
mod OccName
occ Name
name
= (OccEnv Name -> OccEnv Name -> OccEnv Name)
-> OrigNameCache -> Module -> OccEnv Name -> OrigNameCache
forall a.
(a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnvWith OccEnv Name -> OccEnv Name -> OccEnv Name
combine OrigNameCache
nc Module
mod (OccName -> Name -> OccEnv Name
forall a. OccName -> a -> OccEnv a
unitOccEnv OccName
occ Name
name)
where
combine :: OccEnv Name -> OccEnv Name -> OccEnv Name
combine OccEnv Name
_ OccEnv Name
occ_env = OccEnv Name -> OccName -> Name -> OccEnv Name
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv Name
occ_env OccName
occ Name
name
initNameCache :: Char -> [Name] -> IO NameCache
initNameCache :: Char -> [Name] -> IO NameCache
initNameCache Char
c [Name]
names = Char -> MVar OrigNameCache -> NameCache
NameCache Char
c (MVar OrigNameCache -> NameCache)
-> IO (MVar OrigNameCache) -> IO NameCache
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OrigNameCache -> IO (MVar OrigNameCache)
forall a. a -> IO (MVar a)
newMVar ([Name] -> OrigNameCache
initOrigNames [Name]
names)
initOrigNames :: [Name] -> OrigNameCache
initOrigNames :: [Name] -> OrigNameCache
initOrigNames [Name]
names = (OrigNameCache -> Name -> OrigNameCache)
-> OrigNameCache -> [Name] -> OrigNameCache
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' OrigNameCache -> Name -> OrigNameCache
extendOrigNameCache' OrigNameCache
forall a. ModuleEnv a
emptyModuleEnv [Name]
names
updateNameCache'
:: NameCache
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache' :: forall c.
NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
updateNameCache' (NameCache Char
_c MVar OrigNameCache
nc) OrigNameCache -> IO (OrigNameCache, c)
upd_fn = MVar OrigNameCache
-> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar' MVar OrigNameCache
nc OrigNameCache -> IO (OrigNameCache, c)
upd_fn
modifyMVar' :: MVar a -> (a -> IO (a,b)) -> IO b
modifyMVar' :: forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar' MVar a
m a -> IO (a, b)
f = MVar a -> (a -> IO (a, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar a
m ((a -> IO (a, b)) -> IO b) -> (a -> IO (a, b)) -> IO b
forall a b. (a -> b) -> a -> b
$ a -> IO (a, b)
f (a -> IO (a, b)) -> ((a, b) -> IO (a, b)) -> a -> IO (a, b)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \(a, b)
c -> (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
c a -> IO (a, b) -> IO (a, b)
forall a b. a -> b -> b
`seq` (a, b) -> IO (a, b)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, b)
c
updateNameCache
:: NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache :: forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
name_cache !Module
_mod !OccName
_occ OrigNameCache -> IO (OrigNameCache, c)
upd_fn
= NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
forall c.
NameCache -> (OrigNameCache -> IO (OrigNameCache, c)) -> IO c
updateNameCache' NameCache
name_cache OrigNameCache -> IO (OrigNameCache, c)
upd_fn