{-# LANGUAGE RankNTypes #-}

-- | The Name Cache
module GHC.Types.Name.Cache
  ( NameCache (..)
  , newNameCache
  , initNameCache
  , takeUniqFromNameCache
  , updateNameCache'
  , updateNameCache

  -- * OrigNameCache
  , OrigNameCache
  , lookupOrigNameCache
  , extendOrigNameCache'
  , extendOrigNameCache

  -- * Known-key names
  , knownKeysOrigNameCache
  , isKnownOrigName_maybe
  )
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.Builtin.Utils

import GHC.Utils.Outputable
import GHC.Utils.Panic

import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad

{-

Note [The Name Cache]
~~~~~~~~~~~~~~~~~~~~~
The Name Cache makes sure that, during any invocation of GHC, each
External Name "M.x" has one, and only one globally-agreed Unique.

* The first time we come across M.x we make up a Unique and record that
  association in the Name Cache.

* When we come across "M.x" again, we look it up in the Name Cache,
  and get a hit.

The functions newGlobalBinder, allocateGlobalBinder do the main work.
When you make an External name, you should probably be calling one
of them.

Names in a NameCache are always stored as a Global, and have the SrcLoc of their
binding locations.  Actually that's not quite right.  When we first encounter
the original name, we might not be at its binding site (e.g. we are reading an
interface file); so we give it 'noSrcLoc' then.  Later, when we find its binding
site, we fix it up.


Note [Built-in syntax and the OrigNameCache]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Built-in syntax refers to names that are always in scope and can't be imported
or exported. Such names come in two varieties:

* Simple names (finite): `[]`, `:`, `->`
* Families of names (infinite):
    * boxed tuples `()`, `(,)`, `(,,)`, `(,,,)`, ...
    * unboxed tuples `(##)`, `(#,#)`, `(#,,#)`, ...
    * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ...
    * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ...

Concretely, a built-in name is a WiredIn Name that has a BuiltInSyntax flag.

Historically, GHC used to avoid putting any built-in syntax in the OrigNameCache
to avoid dealing with infinite families of names (tuples and sums). This measure
has become inadequate with the introduction of NoListTuplePuns (GHC Proposal #475).
Nowadays tuples and sums also use Names that are WiredIn, but are not BuiltInSyntax:

* boxed tuples      (tycons):   Unit, Solo, Tuple2, Tuple3, Tuple4, ...
* unboxed tuples    (tycons):   Unit#, Solo#, Tuple2#, Tuple3#, Tuple4#, ...
* constraint tuples (tycons):   CUnit, CSolo, CTuple2, CTuple3, CTuple4, ...
* one-tuples      (datacons):   MkSolo, MkSolo#

We can't put infinitely many names in a finite data structure (OrigNameCache).
So we deal with them in lookupOrigNameCache by means of isInfiniteFamilyOrigName_maybe.

At the same time, simple finite built-in names (`[]`, `:`, `->`) can be put in
the OrigNameCache without any issues (they end up there because they're
knownKeyNames). It doesn't matter that they're built-in syntax.

One might wonder: what's the point of having any built-in syntax in the
OrigNameCache at all?  Good question; after all,
  1) The parser emits built-in and punned syntax directly as Exact RdrNames
  2) Template Haskell conversion (GHC.ThToHs) matches on built-in and punned
     syntax directly to immediately produce Exact names (GHC.ThToHs.thRdrName)
  3) Loading of interface files encodes names via Uniques, as detailed in
     Note [Symbol table representation of names] in GHC.Iface.Binary

It turns out that we end up looking up built-in syntax in the cache when we
generate Haddock documentation. E.g. if we don't find tuple data constructors
there, hyperlinks won't work as expected. Test case: haddockHtmlTest (Bug923.hs)
-}

-- | The NameCache makes sure that there is just one Unique assigned for
-- each original name; i.e. (module-name, occ-name) pair and provides
-- something of a lookup mechanism for those names.
data NameCache = NameCache
  { NameCache -> Char
nsUniqChar :: {-# UNPACK #-} !Char
  , NameCache -> MVar OrigNameCache
nsNames    :: {-# UNPACK #-} !(MVar OrigNameCache)
  }

-- | Per-module cache of original 'OccName's given 'Name's
type OrigNameCache   = ModuleEnv (OccEnv Name)

takeUniqFromNameCache :: NameCache -> IO Unique
takeUniqFromNameCache :: NameCache -> IO Unique
takeUniqFromNameCache (NameCache Char
c MVar OrigNameCache
_) = Char -> IO Unique
uniqFromTag Char
c

lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
nc Module
mod OccName
occ = Maybe Name
lookup_infinite Maybe Name -> Maybe Name -> Maybe Name
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Name
lookup_normal
  where
    -- See Note [Known-key names], 3(c) in GHC.Builtin.Names
    -- and Note [Infinite families of known-key names]
    lookup_infinite :: Maybe Name
lookup_infinite = Module -> OccName -> Maybe Name
isInfiniteFamilyOrigName_maybe Module
mod OccName
occ
    lookup_normal :: Maybe Name
lookup_normal = do
      occ_env <- OrigNameCache -> Module -> Maybe (OccEnv Name)
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv OrigNameCache
nc Module
mod
      lookupOccEnv occ_env 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 (HasDebugCallStack => 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

newNameCache :: Char -> OrigNameCache -> IO NameCache
newNameCache :: Char -> OrigNameCache -> IO NameCache
newNameCache Char
c OrigNameCache
nc = 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 OrigNameCache
nc

initNameCache :: Char -> [Name] -> IO NameCache
initNameCache :: Char -> [Name] -> IO NameCache
initNameCache Char
c [Name]
names = Char -> OrigNameCache -> IO NameCache
newNameCache Char
c ([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

-- | Update the name cache with the given function
updateNameCache'
  :: NameCache
  -> (OrigNameCache -> IO (OrigNameCache, c))  -- The updating function
  -> 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

-- this should be in `base`
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

-- | Update the name cache with the given function
--
-- Additionally, it ensures that the given Module and OccName are evaluated.
-- If not, chaos can ensue:
--      we read the name-cache
--      then pull on mod (say)
--      which does some stuff that modifies the name cache
-- This did happen, with tycon_mod in GHC.IfaceToCore.tcIfaceAlt (DataAlt..)
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

{-# NOINLINE knownKeysOrigNameCache #-}
knownKeysOrigNameCache :: OrigNameCache
knownKeysOrigNameCache :: OrigNameCache
knownKeysOrigNameCache = [Name] -> OrigNameCache
initOrigNames [Name]
knownKeyNames

isKnownOrigName_maybe :: Module -> OccName -> Maybe Name
isKnownOrigName_maybe :: Module -> OccName -> Maybe Name
isKnownOrigName_maybe = OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
knownKeysOrigNameCache