-- (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.DynFlags

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 { hsc_env <- TcRnIf a b HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; name <- liftIO $ allocateGlobalBinder (hsc_NC hsc_env) mod occ loc
       ; traceIf (text "newGlobalBinder" <+>
                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))
       ; return 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
  = NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, Name))
-> IO Name
forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ ((OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name)
-> (OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name
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
                  -> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache0, Name
name)
                  | Bool
otherwise
                  -> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
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
              uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
              let name      = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
loc
              let new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name
              pure (new_cache, name)

ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]
ifaceExportNames :: forall gbl lcl. [IfaceExport] -> TcRnIf gbl lcl [IfaceExport]
ifaceExportNames [IfaceExport]
exports = [IfaceExport] -> IOEnv (Env gbl lcl) [IfaceExport]
forall a. a -> IOEnv (Env gbl lcl) a
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
  hsc_env <- TcRnIf a b HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
  traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)
  liftIO $ lookupNameCache (hsc_NC hsc_env) mod 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 = NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, Name))
-> IO Name
forall c.
NameCache
-> Module
-> OccName
-> (OrigNameCache -> IO (OrigNameCache, c))
-> IO c
updateNameCache NameCache
nc Module
mod OccName
occ ((OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name)
-> (OrigNameCache -> IO (OrigNameCache, Name)) -> IO Name
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 -> (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OrigNameCache
cache0, Name
name)
    Maybe Name
Nothing   -> do
      uniq <- NameCache -> IO Unique
takeUniqFromNameCache NameCache
nc
      let name      = Unique -> Module -> OccName -> SrcSpan -> Name
mkExternalName Unique
uniq Module
mod OccName
occ SrcSpan
noSrcSpan
      let new_cache = OrigNameCache -> Module -> OccName -> Name -> OrigNameCache
extendOrigNameCache OrigNameCache
cache0 Module
mod OccName
occ Name
name
      pure (new_cache, 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 OccName -> IOEnv (Env m n) () -> IOEnv (Env m n) ()
forall a b. a -> b -> b
`seq` () -> IOEnv (Env m n) ()
forall a. a -> IOEnv (Env m n) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- c.f. seq in newGlobalBinder
       ; hsc_env <- TcRnIf m n HscEnv
forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
       ; liftIO $ updateNameCache (hsc_NC hsc_env) mod occ $ \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'
         (OrigNameCache, Name) -> IO (OrigNameCache, Name)
forall a. a -> IO a
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 = Name -> IOEnv (Env m n) Name
forall a. a -> IOEnv (Env m n) a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
setNameModule (Just Module
m) Name
n =
    Module -> OccName -> SrcSpan -> IOEnv (Env m n) Name
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  { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; case lookupFsEnv (if_id_env lcl) occ of
            Just Id
ty_var -> Id -> IfL Id
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
            Maybe Id
Nothing     -> SDoc -> IfL Id
forall a. SDoc -> IfL a
failIfM (SDoc -> IfL Id) -> SDoc -> IfL Id
forall a b. (a -> b) -> a -> b
$
              [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
                [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iface id out of scope: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
occ
                , String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"env:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastStringEnv Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (IfLclEnv -> FastStringEnv Id
if_id_env IfLclEnv
lcl) ]
        }

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


tcIfaceTyVar :: FastString -> IfL TyVar
tcIfaceTyVar :: FastString -> IfL Id
tcIfaceTyVar FastString
occ
  = do  { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; case lookupFsEnv (if_tv_env lcl) occ of
            Just Id
ty_var -> Id -> IfL Id
forall a. a -> IOEnv (Env IfGblEnv IfLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return Id
ty_var
            Maybe Id
Nothing     -> SDoc -> IfL Id
forall a. SDoc -> IfL a
failIfM (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Iface type variable out of scope: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> 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  { lcl <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv
        ; return (lookupFsEnv (if_tv_env lcl) occ) }

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

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

extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a
extendIfaceEnvs :: forall a. [Id] -> IfL a -> IfL a
extendIfaceEnvs [Id]
tcvs IfL a
thing_inside
  = [Id] -> IfL a -> IfL a
forall a. [Id] -> IfL a -> IfL a
extendIfaceTyVarEnv [Id]
tvs (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
    [Id] -> IfL a -> IfL a
forall a. [Id] -> IfL a -> IfL a
extendIfaceIdEnv    [Id]
cvs (IfL a -> IfL a) -> IfL a -> IfL a
forall a b. (a -> b) -> a -> b
$
    IfL a
thing_inside
  where
    ([Id]
tvs, [Id]
cvs) = (Id -> Bool) -> [Id] -> ([Id], [Id])
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  { env <- TcRnIf IfGblEnv IfLclEnv IfLclEnv
forall gbl lcl. TcRnIf gbl lcl lcl
getLclEnv; lookupOrig (if_mod env) occ }

newIfaceName :: OccName -> IfL Name
newIfaceName :: OccName -> IfL Name
newIfaceName OccName
occ
  = do  { uniq <- TcRnIf IfGblEnv IfLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
        ; return $! mkInternalName uniq occ noSrcSpan }

newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames :: [OccName] -> IfL [Name]
newIfaceNames [OccName]
occs
  = do  { uniqs <- IOEnv (Env IfGblEnv IfLclEnv) [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM
        ; return [ mkInternalName uniq occ noSrcSpan
                 | (occ,uniq) <- occs `zip` uniqs] }

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