-- (c) The University of Glasgow 2002-2006

{-# LANGUAGE RankNTypes #-}

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,

        -- Name-cache stuff
        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

{-
*********************************************************
*                                                      *
        Allocating new Names in the Name Cache
*                                                      *
*********************************************************

See Also: Note [The Name Cache] in GHC.Types.Name.Cache
-}

newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
-- Used for source code and interface files, to make the
-- Name for a thing, given its Module and OccName
-- See Note [The Name Cache] in GHC.Types.Name.Cache
--
-- The cache may already have a binding for this thing,
-- because we may have seen an occurrence before, but now is the
-- moment when we know its Module and SrcLoc in their full glory

newGlobalBinder :: forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
mod OccName
occ SrcSpan
loc
  = do { HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; Name
name <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) Module
mod OccName
occ SrcSpan
loc
       ; forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"newGlobalBinder" SDoc -> SDoc -> SDoc
<+>
                  ([SDoc] -> SDoc
vcat [ forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr OccName
occ SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr SrcSpan
loc, forall a. Outputable a => a -> SDoc
ppr Name
name]))
       ; forall (m :: * -> *) a. Monad m => a -> m a
return Name
name }

newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
-- Works in the IO monad, and gets the Module
-- from the interactive context
newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name
newInteractiveBinder HscEnv
hsc_env OccName
occ SrcSpan
loc = do
  let mod :: Module
mod = InteractiveContext -> Module
icInteractiveModule (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
  NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) Module
mod OccName
occ SrcSpan
loc

allocateGlobalBinder
  :: NameCache
  -> Module -> OccName -> SrcSpan
  -> IO Name
-- See Note [The Name Cache] in GHC.Types.Name.Cache
allocateGlobalBinder :: NameCache -> Module -> OccName -> SrcSpan -> IO Name
allocateGlobalBinder NameCache
nc Module
mod OccName
occ SrcSpan
loc
  = forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache0 -> do
      case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ of
        -- A hit in the cache!  We are at the binding site of the name.
        -- This is the moment when we know the SrcLoc
        -- of the Name, so we set this field in the Name we return.
        --
        -- Then (bogus) multiple bindings of the same Name
        -- get different SrcLocs can be reported as such.
        --
        -- Possible other reason: it might be in the cache because we
        --      encountered an occurrence before the binding site for an
        --      implicitly-imported Name.  Perhaps the current SrcLoc is
        --      better... but not really: it'll still just say 'imported'
        --
        -- IMPORTANT: Don't mess with wired-in names.
        --            Their wired-in-ness is in their NameSort
        --            and their Module is correct.

        Just Name
name | Name -> Bool
isWiredInName Name
name
                  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache0, Name
name)
                  | Bool
otherwise
                  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
new_cache, Name
name')
                  where
                    uniq :: Unique
uniq      = Name -> Unique
nameUnique Name
name
                    name' :: Name
name'     = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
                                -- name' is like name, but with the right SrcSpan
                    new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name'

        -- Miss in the cache!
        -- Build a completely new Name, and put it in the cache
        Maybe Name
_ -> do
              Unique
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
              let name :: Name
name      = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
              let new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name
              forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
new_cache, Name
name)

ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames :: forall gbl lcl. [IfaceExport] -> TcRnIf gbl lcl [IfaceExport]
ifaceExportNames [IfaceExport]
exports = forall (m :: * -> *) a. Monad m => a -> m a
return [IfaceExport]
exports

{-
************************************************************************
*                                                                      *
                Name cache access
*                                                                      *
************************************************************************
-}

-- | Look up the 'Name' for a given 'Module' and 'OccName'.
-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad
-- and 'Module' is simply that of the 'ModIface' you are typechecking.
lookupOrig :: Module -> OccName -> TcRnIf a b Name
lookupOrig :: forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig Module
mod OccName
occ = do
  HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
  forall m n. SDoc -> TcRnIf m n ()
traceIf (String -> SDoc
text String
"lookup_orig" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr OccName
occ)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ NameCache -> Module -> OccName -> IO Name
lookupNameCache (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) Module
mod OccName
occ

lookupNameCache :: NameCache -> Module -> OccName -> IO Name
-- Lookup up the (Module,OccName) in the NameCache
-- If you find it, return it; if not, allocate a fresh original name and extend
-- the NameCache.
-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.
-- If we need to explore its value we will load Foo.hi; but meanwhile all we
-- need is a Name for it.
lookupNameCache :: NameCache -> Module -> OccName -> IO Name
lookupNameCache NameCache
nc Module
mod OccName
occ = forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache0 ->
  case OrigNameCache -> Module -> OccName -> Maybe Name
lookupOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ of
    Just Name
name -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache0, Name
name)
    Maybe Name
Nothing   -> do
      Unique
uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
      let name :: Name
name      = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
noSrcSpan
      let new_cache :: OrigNameCache
new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
new_cache, Name
name)

externaliseName :: Module -> Name -> TcRnIf m n Name
-- Take an Internal Name and make it an External one,
-- with the same unique
externaliseName :: forall m n. Module -> Name -> TcRnIf m n Name
externaliseName Module
mod Name
name
  = do { let occ :: OccName
occ = Name -> OccName
nameOccName Name
name
             loc :: SrcSpan
loc = Name -> SrcSpan
nameSrcSpan Name
name
             uniq :: Unique
uniq = Name -> Unique
nameUnique Name
name
       ; OccName
occ seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- c.f. seq in newGlobalBinder
       ; HscEnv
hsc_env <- forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache (HscEnv -> NameCache
hsc_NC HscEnv
hsc_env) Module
mod OccName
occ forall a b. (a -> b) -> a -> b
$ \OrigNameCache
cache -> do
         let name' :: Name
name'  = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
             cache' :: OrigNameCache
cache' = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache Module
mod OccName
occ Name
name'
         forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache', Name
name') }

-- | Set the 'Module' of a 'Name'.
setNameModule :: Maybe Module -> Name -> TcRnIf m n Name
setNameModule :: forall m n. Maybe Module -> Name -> TcRnIf m n Name
setNameModule Maybe Module
Nothing Name
n = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
setNameModule (Just Module
m) Name
n =
    forall a b. Module -> OccName -> SrcSpan -> TcRnIf a b Name
newGlobalBinder Module
m (Name -> OccName
nameOccName Name
n) (Name -> SrcSpan
nameSrcSpan Name
n)

{-
************************************************************************
*                                                                      *
                Type variables and local Ids
*                                                                      *
************************************************************************
-}

tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId :: FastString -> IfL Id
tcIfaceLclId FastString
occ
  = do  { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; case (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
lcl) FastString
occ) of
            Just Id
ty_var -> forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
            Maybe Id
Nothing     -> forall a. SDoc -> IfL a
failIfM (String -> SDoc
text String
"Iface id out of scope: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr FastString
occ)
        }

extendIfaceIdEnv :: [Id] -> IfL a -> IfL a
extendIfaceIdEnv :: forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv [Id]
ids
  = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv forall a b. (a -> b) -> a -> b
$ \IfLclEnv
env ->
    let { id_env' :: FastStringEnv Id
id_env' = forall a. FastStringEnv a -> [(FastString, a)] -> FastStringEnv a
extendFsEnvList (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
env) [(FastString, Id)]
pairs
        ; pairs :: [(FastString, Id)]
pairs   = [(OccName -> FastString
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
id), Id
id) | Id
id <- [Id]
ids] }
    in IfLclEnv
env { if_id_env :: FastStringEnv Id
if_id_env = FastStringEnv Id
id_env' }


tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar :: FastString -> IfL Id
tcIfaceTyVar FastString
occ
  = do  { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; case (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
lcl) FastString
occ) of
            Just Id
ty_var -> forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
            Maybe Id
Nothing     -> forall a. SDoc -> IfL a
failIfM (String -> SDoc
text String
"Iface type variable out of scope: " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr FastString
occ)
        }

lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)
lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe Id)
lookupIfaceTyVar (FastString
occ, IfaceKind
_)
  = do  { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
lcl) FastString
occ) }

lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)
lookupIfaceVar :: IfaceBndr -> IfL (Maybe Id)
lookupIfaceVar (IfaceIdBndr (IfaceKind
_, FastString
occ, IfaceKind
_))
  = do  { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
lcl) FastString
occ) }
lookupIfaceVar (IfaceTvBndr (FastString
occ, IfaceKind
_))
  = do  { IfLclEnv
lcl <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
lcl) FastString
occ) }

extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a
extendIfaceTyVarEnv :: forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tyvars
  = forall lcl gbl a.
(lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
updLclEnv forall a b. (a -> b) -> a -> b
$ \IfLclEnv
env ->
    let { tv_env' :: FastStringEnv Id
tv_env' = forall a. FastStringEnv a -> [(FastString, a)] -> FastStringEnv a
extendFsEnvList (IfLclEnv -> FastStringEnv Id
if_tv_env IfLclEnv
env) [(FastString, Id)]
pairs
        ; pairs :: [(FastString, Id)]
pairs   = [(OccName -> FastString
occNameFS (forall a. NamedThing a => a -> OccName
getOccName Id
tv), Id
tv) | Id
tv <- [Id]
tyvars] }
    in IfLclEnv
env { if_tv_env :: FastStringEnv Id
if_tv_env = FastStringEnv Id
tv_env' }

extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs :: forall a. [Id] -> IfL a -> IfL a
extendIfaceEnvs [Id]
tcvs IfL a
thing_inside
  = forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tvs forall a b. (a -> b) -> a -> b
$
    forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv    [Id]
cvs forall a b. (a -> b) -> a -> b
$
    IfL a
thing_inside
  where
    ([Id]
tvs, [Id]
cvs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
tcvs

{-
************************************************************************
*                                                                      *
                Getting from RdrNames to Names
*                                                                      *
************************************************************************
-}

-- | Look up a top-level name from the current Iface module
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop :: OccName -> IfL Name
lookupIfaceTop OccName
occ
  = do  { IfLclEnv
env <- forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; forall a b. Module -> OccName -> TcRnIf a b Name
lookupOrig (IfLclEnv -> Module
if_mod IfLclEnv
env) OccName
occ }

newIfaceName :: OccName -> IfL Name
newIfaceName :: OccName -> IfL Name
newIfaceName OccName
occ
  = do  { Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
noSrcSpan }

newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames [OccName]
occs
  = do  { UniqSupply
uniqs <- forall gbl lcl. TcRnIf gbl lcl UniqSupply
newUniqueSupply
        ; forall (m :: * -> *) a. Monad m => a -> m a
return [ Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq OccName
occ SrcSpan
noSrcSpan
                 | (OccName
occ,Unique
uniq) <- [OccName]
occs forall a b. [a] -> [b] -> [(a, b)]
`zip` UniqSupply -> [Unique]
uniqsFromSupply UniqSupply
uniqs] }

trace_if :: Logger -> SDoc -> IO ()
{-# INLINE trace_if #-}
trace_if :: Logger -> SDoc -> IO ()
trace_if Logger
logger SDoc
doc = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace) forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
doc

trace_hi_diffs :: Logger -> SDoc -> IO ()
{-# INLINE trace_hi_diffs #-}
trace_hi_diffs :: Logger -> SDoc -> IO ()
trace_hi_diffs Logger
logger SDoc
doc = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_hi_diffs) forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger SDoc
doc