-- | Dynamically lookup up values from modules and loading them.
module GHC.Runtime.Loader (
        initializePlugins, initializeSessionPlugins,
        -- * Loading plugins
        loadFrontendPlugin,

        -- * Force loading information
        forceLoadModuleInterfaces,
        forceLoadNameModuleInterface,
        forceLoadTyCon,

        -- * Finding names
        lookupRdrNameInModuleForPlugins,

        -- * Loading values
        getValueSafely,
        getHValueSafely,
        lessUnsafeCoerce
    ) where

import GHC.Prelude
import GHC.Data.FastString

import GHC.Driver.DynFlags
import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Driver.Plugins
import GHC.Driver.Plugins.External

import GHC.Linker.Loader       ( loadModule, loadName )
import GHC.Runtime.Interpreter ( wormhole )
import GHC.Runtime.Interpreter.Types

import GHC.Rename.Names ( gresFromAvails )

import GHC.Tc.Utils.Monad      ( initTcInteractive, initIfaceTcRn )
import GHC.Iface.Load          ( loadPluginInterface, cannotFindModule )
import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName )

import GHC.Driver.Env
import GHCi.RemoteTypes     ( HValue )
import GHC.Core.Type        ( Type, mkTyConTy )
import GHC.Core.TyCo.Compare( eqType )
import GHC.Core.TyCon       ( TyCon(tyConName) )


import GHC.Types.SrcLoc        ( noSrcSpan )
import GHC.Types.Name    ( Name, nameModule, nameModule_maybe )
import GHC.Types.Id      ( idType )
import GHC.Types.PkgQual
import GHC.Types.TyThing
import GHC.Types.Name.Occurrence ( OccName, mkVarOccFS )
import GHC.Types.Name.Reader
import GHC.Types.Unique.DFM

import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )
import GHC.Driver.Config.Finder ( initFinderOpts )
import GHC.Driver.Config.Diagnostic ( initIfaceMessageOpts )
import GHC.Unit.Module   ( Module, ModuleName, thisGhcUnit, GenModule(moduleUnit), IsBootInterface(NotBoot) )
import GHC.Unit.Module.ModIface
import GHC.Unit.Env

import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Utils.Misc ( HasDebugCallStack )
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception

import Control.Monad     ( unless )
import Data.Maybe        ( mapMaybe )
import Unsafe.Coerce     ( unsafeCoerce )
import GHC.Linker.Types
import Data.List (unzip4)
import GHC.Iface.Errors.Ppr
import GHC.Driver.Monad

{- Note [Timing of plugin initialization]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Plugins needs to be initialised as soon as possible in the pipeline. This is because
driver plugins are executed immediately after being loaded, which can modify anything
in the HscEnv, including the logger and DynFlags (for example #21279). For example,
in ghc/Main.hs the logger is used almost immediately after the session has been initialised
and so if a user overwrites the logger expecting all output to go there then unless
the plugins are initialised before that point then unexpected things will happen.

We initialise plugins in ghc/Main.hs for the main ghc executable.

When people are using the GHC API, they also need to initialise plugins
at the highest level possible for things to work as expected. We keep
some defensive calls to plugin initialisation in functions like `load'` and `oneshot`
to catch cases where API users have not initialised their own plugins.

In addition to this, there needs to be an initialisation call for each module
just in case the user has enabled a plugin just for that module using OPTIONS_GHC
pragma.

-}

-- | Initialise plugins specified by the current DynFlags and update the session.
initializeSessionPlugins :: GhcMonad m => m ()
initializeSessionPlugins :: forall (m :: * -> *). GhcMonad m => m ()
initializeSessionPlugins = m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession m HscEnv -> (HscEnv -> m HscEnv) -> m HscEnv
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO HscEnv -> m HscEnv
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HscEnv -> m HscEnv)
-> (HscEnv -> IO HscEnv) -> HscEnv -> m HscEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> IO HscEnv
initializePlugins m HscEnv -> (HscEnv -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession

-- | Loads the plugins specified in the pluginModNames field of the dynamic
-- flags. Should be called after command line arguments are parsed, but before
-- actual compilation starts. Idempotent operation. Should be re-called if
-- pluginModNames or pluginModNameOpts changes.
initializePlugins :: HscEnv -> IO HscEnv
initializePlugins :: HscEnv -> IO HscEnv
initializePlugins HscEnv
hsc_env
    -- check that plugin specifications didn't change

    -- dynamic plugins
  | [LoadedPlugin]
loaded_plugins <- Plugins -> [LoadedPlugin]
loadedPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env)
  , (LoadedPlugin -> ModuleName) -> [LoadedPlugin] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map LoadedPlugin -> ModuleName
lpModuleName [LoadedPlugin]
loaded_plugins [ModuleName] -> [ModuleName] -> Bool
forall a. Eq a => a -> a -> Bool
== [ModuleName] -> [ModuleName]
forall a. [a] -> [a]
reverse (DynFlags -> [ModuleName]
pluginModNames DynFlags
dflags)
  , (LoadedPlugin -> Bool) -> [LoadedPlugin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LoadedPlugin -> Bool
same_args [LoadedPlugin]
loaded_plugins

    -- external plugins
  , [ExternalPlugin]
external_plugins <- Plugins -> [ExternalPlugin]
externalPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env)
  , [ExternalPlugin] -> [ExternalPluginSpec] -> Bool
check_external_plugins [ExternalPlugin]
external_plugins (DynFlags -> [ExternalPluginSpec]
externalPluginSpecs DynFlags
dflags)

    -- ensure we have initialised static plugins
  , (StaticPlugin -> Bool) -> [StaticPlugin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all StaticPlugin -> Bool
spInitialised (Plugins -> [StaticPlugin]
staticPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env))

  = HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env -- no change, no need to reload plugins

  | Bool
otherwise
  = do (loaded_plugins, links, pkgs) <- HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
loadPlugins HscEnv
hsc_env
       external_plugins <- loadExternalPlugins (externalPluginSpecs dflags)
       let plugins' = (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) { staticPlugins    = map (\StaticPlugin
sp -> StaticPlugin
sp{ spInitialised = True }) $ staticPlugins (hsc_plugins hsc_env)
                                            , externalPlugins  = external_plugins
                                            , loadedPlugins    = loaded_plugins
                                            , loadedPluginDeps = (links, pkgs)
                                            }
       let hsc_env' = HscEnv
hsc_env { hsc_plugins = plugins' }
       withPlugins (hsc_plugins hsc_env') driverPlugin hsc_env'
  where
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    -- dynamic plugins
    plugin_args :: [(ModuleName, CommandLineOption)]
plugin_args = DynFlags -> [(ModuleName, CommandLineOption)]
pluginModNameOpts DynFlags
dflags
    same_args :: LoadedPlugin -> Bool
same_args LoadedPlugin
p = PluginWithArgs -> [CommandLineOption]
paArguments (LoadedPlugin -> PluginWithArgs
lpPlugin LoadedPlugin
p) [CommandLineOption] -> [CommandLineOption] -> Bool
forall a. Eq a => a -> a -> Bool
== LoadedPlugin
-> [(ModuleName, CommandLineOption)] -> [CommandLineOption]
forall {b}. LoadedPlugin -> [(ModuleName, b)] -> [b]
argumentsForPlugin LoadedPlugin
p [(ModuleName, CommandLineOption)]
plugin_args
    argumentsForPlugin :: LoadedPlugin -> [(ModuleName, b)] -> [b]
argumentsForPlugin LoadedPlugin
p = ((ModuleName, b) -> b) -> [(ModuleName, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, b) -> b
forall a b. (a, b) -> b
snd ([(ModuleName, b)] -> [b])
-> ([(ModuleName, b)] -> [(ModuleName, b)])
-> [(ModuleName, b)]
-> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ModuleName, b) -> Bool) -> [(ModuleName, b)] -> [(ModuleName, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== LoadedPlugin -> ModuleName
lpModuleName LoadedPlugin
p) (ModuleName -> Bool)
-> ((ModuleName, b) -> ModuleName) -> (ModuleName, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, b) -> ModuleName
forall a b. (a, b) -> a
fst)
    -- external plugins
    check_external_plugin :: ExternalPlugin -> ExternalPluginSpec -> Bool
check_external_plugin ExternalPlugin
p ExternalPluginSpec
spec = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
      [ ExternalPlugin -> CommandLineOption
epUnit                ExternalPlugin
p  CommandLineOption -> CommandLineOption -> Bool
forall a. Eq a => a -> a -> Bool
== ExternalPluginSpec -> CommandLineOption
esp_unit_id ExternalPluginSpec
spec
      , ExternalPlugin -> CommandLineOption
epModule              ExternalPlugin
p  CommandLineOption -> CommandLineOption -> Bool
forall a. Eq a => a -> a -> Bool
== ExternalPluginSpec -> CommandLineOption
esp_module ExternalPluginSpec
spec
      , PluginWithArgs -> [CommandLineOption]
paArguments (ExternalPlugin -> PluginWithArgs
epPlugin ExternalPlugin
p) [CommandLineOption] -> [CommandLineOption] -> Bool
forall a. Eq a => a -> a -> Bool
== ExternalPluginSpec -> [CommandLineOption]
esp_args ExternalPluginSpec
spec
      ]
    check_external_plugins :: [ExternalPlugin] -> [ExternalPluginSpec] -> Bool
check_external_plugins [ExternalPlugin]
eps [ExternalPluginSpec]
specs = case ([ExternalPlugin]
eps,[ExternalPluginSpec]
specs) of
      ([]  , [])  -> Bool
True
      ([ExternalPlugin]
_   , [])  -> Bool
False -- some external plugin removed
      ([]  , [ExternalPluginSpec]
_ )  -> Bool
False -- some external plugin added
      (ExternalPlugin
p:[ExternalPlugin]
ps,ExternalPluginSpec
s:[ExternalPluginSpec]
ss) -> ExternalPlugin -> ExternalPluginSpec -> Bool
check_external_plugin ExternalPlugin
p ExternalPluginSpec
s Bool -> Bool -> Bool
&& [ExternalPlugin] -> [ExternalPluginSpec] -> Bool
check_external_plugins [ExternalPlugin]
ps [ExternalPluginSpec]
ss

loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
loadPlugins :: HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
loadPlugins HscEnv
hsc_env
  = do { Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
to_load) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
           HscEnv -> IO ()
checkExternalInterpreter HscEnv
hsc_env
       ; plugins_with_deps <- (ModuleName -> IO (Plugin, ModIface, [Linkable], PkgsLoaded))
-> [ModuleName] -> IO [(Plugin, ModIface, [Linkable], PkgsLoaded)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ModuleName -> IO (Plugin, ModIface, [Linkable], PkgsLoaded)
loadPlugin [ModuleName]
to_load
       ; let (plugins, ifaces, links, pkgs) = unzip4 plugins_with_deps
       ; return (zipWith attachOptions to_load (zip plugins ifaces), concat links, foldl' plusUDFM emptyUDFM pkgs)
       }
  where
    dflags :: DynFlags
dflags  = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    to_load :: [ModuleName]
to_load = [ModuleName] -> [ModuleName]
forall a. [a] -> [a]
reverse ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [ModuleName]
pluginModNames DynFlags
dflags

    attachOptions :: ModuleName -> (Plugin, ModIface) -> LoadedPlugin
attachOptions ModuleName
mod_nm (Plugin
plug, ModIface
mod) =
        PluginWithArgs -> ModIface -> LoadedPlugin
LoadedPlugin (Plugin -> [CommandLineOption] -> PluginWithArgs
PluginWithArgs Plugin
plug ([CommandLineOption] -> [CommandLineOption]
forall a. [a] -> [a]
reverse [CommandLineOption]
options)) ModIface
mod
      where
        options :: [CommandLineOption]
options = [ CommandLineOption
option | (ModuleName
opt_mod_nm, CommandLineOption
option) <- DynFlags -> [(ModuleName, CommandLineOption)]
pluginModNameOpts DynFlags
dflags
                            , ModuleName
opt_mod_nm ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
mod_nm ]
    loadPlugin :: ModuleName -> IO (Plugin, ModIface, [Linkable], PkgsLoaded)
loadPlugin = OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (Plugin, ModIface, [Linkable], PkgsLoaded)
forall a.
OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (a, ModIface, [Linkable], PkgsLoaded)
loadPlugin' (FastString -> OccName
mkVarOccFS (CommandLineOption -> FastString
fsLit CommandLineOption
"plugin")) Name
pluginTyConName HscEnv
hsc_env


loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
loadFrontendPlugin :: HscEnv -> ModuleName -> IO (FrontendPlugin, [Linkable], PkgsLoaded)
loadFrontendPlugin HscEnv
hsc_env ModuleName
mod_name = do
    HscEnv -> IO ()
checkExternalInterpreter HscEnv
hsc_env
    (plugin, _iface, links, pkgs)
      <- OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (FrontendPlugin, ModIface, [Linkable], PkgsLoaded)
forall a.
OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (a, ModIface, [Linkable], PkgsLoaded)
loadPlugin' (FastString -> OccName
mkVarOccFS (CommandLineOption -> FastString
fsLit CommandLineOption
"frontendPlugin")) Name
frontendPluginTyConName
           HscEnv
hsc_env ModuleName
mod_name
    return (plugin, links, pkgs)

-- #14335
checkExternalInterpreter :: HscEnv -> IO ()
checkExternalInterpreter :: HscEnv -> IO ()
checkExternalInterpreter HscEnv
hsc_env = case Interp -> InterpInstance
interpInstance (Interp -> InterpInstance) -> Maybe Interp -> Maybe InterpInstance
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Maybe Interp
hsc_interp HscEnv
hsc_env of
  Just (ExternalInterp {})
    -> GhcException -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (CommandLineOption -> GhcException
InstallationError CommandLineOption
"Plugins require -fno-external-interpreter")
  Maybe InterpInstance
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface, [Linkable], PkgsLoaded)
loadPlugin' :: forall a.
OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (a, ModIface, [Linkable], PkgsLoaded)
loadPlugin' OccName
occ_name Name
plugin_name HscEnv
hsc_env ModuleName
mod_name
  = do { let plugin_rdr_name :: RdrName
plugin_rdr_name = ModuleName -> OccName -> RdrName
mkRdrQual ModuleName
mod_name OccName
occ_name
             dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
       ; mb_name <- HasDebugCallStack =>
HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface))
HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins HscEnv
hsc_env ModuleName
mod_name
                        RdrName
plugin_rdr_name
       ; case mb_name of {
            Maybe (Name, ModIface)
Nothing ->
                GhcException -> IO (a, ModIface, [Linkable], PkgsLoaded)
forall a. GhcException -> IO a
throwGhcExceptionIO (CommandLineOption -> GhcException
CmdLineError (CommandLineOption -> GhcException)
-> CommandLineOption -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> CommandLineOption
showSDoc DynFlags
dflags (SDoc -> CommandLineOption) -> SDoc -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                          [ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"The module", ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name
                          , CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"did not export the plugin name"
                          , RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr RdrName
plugin_rdr_name ]) ;
            Just (Name
name, ModIface
mod_iface) ->

     do { plugin_tycon <- HscEnv -> Name -> IO TyCon
forceLoadTyCon HscEnv
hsc_env Name
plugin_name
        ; case thisGhcUnit == (moduleUnit . nameModule . tyConName) plugin_tycon of {
            Bool
False ->
                GhcException -> IO (a, ModIface, [Linkable], PkgsLoaded)
forall a. GhcException -> IO a
throwGhcExceptionIO (CommandLineOption -> GhcException
CmdLineError (CommandLineOption -> GhcException)
-> CommandLineOption -> GhcException
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> CommandLineOption
showSDoc DynFlags
dflags (SDoc -> CommandLineOption) -> SDoc -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                          [ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"The plugin module", ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name
                          , CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"was built with a compiler that is incompatible with the one loading it"
                          ]) ;
            Bool
True ->
     do { eith_plugin <- HscEnv
-> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
forall a.
HscEnv
-> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely HscEnv
hsc_env Name
name (TyCon -> Type
mkTyConTy TyCon
plugin_tycon)
        ; case eith_plugin of
            Left Type
actual_type ->
                GhcException -> IO (a, ModIface, [Linkable], PkgsLoaded)
forall a. GhcException -> IO a
throwGhcExceptionIO (CommandLineOption -> GhcException
CmdLineError (CommandLineOption -> GhcException)
-> CommandLineOption -> GhcException
forall a b. (a -> b) -> a -> b
$
                    DynFlags -> UnitState -> NamePprCtx -> SDoc -> CommandLineOption
showSDocForUser DynFlags
dflags (HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))
                      NamePprCtx
alwaysQualify (SDoc -> CommandLineOption) -> SDoc -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep
                          [ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"The value", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                          , CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"with type", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual_type
                          , CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"did not have the type"
                          , CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"GHC.Plugins.Plugin"
                          , CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"as required"])
            Right (a
plugin, [Linkable]
links, PkgsLoaded
pkgs) -> (a, ModIface, [Linkable], PkgsLoaded)
-> IO (a, ModIface, [Linkable], PkgsLoaded)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
plugin, ModIface
mod_iface, [Linkable]
links, PkgsLoaded
pkgs) } } } } }


-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [GenModule Unit] -> IO ()
forceLoadModuleInterfaces HscEnv
hsc_env SDoc
doc [GenModule Unit]
modules
    = (HscEnv -> TcM () -> IO (Messages TcRnMessage, Maybe ())
forall a. HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive HscEnv
hsc_env (TcM () -> IO (Messages TcRnMessage, Maybe ()))
-> TcM () -> IO (Messages TcRnMessage, Maybe ())
forall a b. (a -> b) -> a -> b
$
       IfG () -> TcM ()
forall a. IfG a -> TcRn a
initIfaceTcRn (IfG () -> TcM ()) -> IfG () -> TcM ()
forall a b. (a -> b) -> a -> b
$
       (GenModule Unit -> IOEnv (Env IfGblEnv ()) ModIface)
-> [GenModule Unit] -> IfG ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> GenModule Unit -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. SDoc -> GenModule Unit -> IfM lcl ModIface
loadPluginInterface SDoc
doc) [GenModule Unit]
modules)
      IO (Messages TcRnMessage, Maybe ()) -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface HscEnv
hsc_env SDoc
reason Name
name = do
    let name_modules :: [GenModule Unit]
name_modules = (Name -> Maybe (GenModule Unit)) -> [Name] -> [GenModule Unit]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Name -> Maybe (GenModule Unit)
nameModule_maybe [Name
name]
    HscEnv -> SDoc -> [GenModule Unit] -> IO ()
forceLoadModuleInterfaces HscEnv
hsc_env SDoc
reason [GenModule Unit]
name_modules

-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
--
-- * The interface could not be loaded
-- * The name is not that of a 'TyCon'
-- * The name did not exist in the loaded module
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon HscEnv
hsc_env Name
con_name = do
    HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface HscEnv
hsc_env (CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"contains a name used in an invocation of loadTyConTy") Name
con_name

    mb_con_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
con_name
    case mb_con_thing of
        Maybe TyThing
Nothing -> DynFlags -> SDoc -> IO TyCon
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO TyCon) -> SDoc -> IO TyCon
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
missingTyThingError Name
con_name
        Just (ATyCon TyCon
tycon) -> TyCon -> IO TyCon
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TyCon
tycon
        Just TyThing
con_thing -> DynFlags -> SDoc -> IO TyCon
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO TyCon) -> SDoc -> IO TyCon
forall a b. (a -> b) -> a -> b
$ Name -> TyThing -> SDoc
wrongTyThingError Name
con_name TyThing
con_thing
  where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at!
--
-- If the value found was not of the correct type, returns @Left <actual_type>@. Any other condition results in an exception:
--
-- * If we could not load the names module
-- * If the thing being loaded is not a value
-- * If the Name does not exist in the module
-- * If the link failed

getValueSafely :: HscEnv -> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely :: forall a.
HscEnv
-> Name -> Type -> IO (Either Type (a, [Linkable], PkgsLoaded))
getValueSafely HscEnv
hsc_env Name
val_name Type
expected_type = do
  eith_hval <- case Hooks
-> Maybe
     (HscEnv
      -> Name
      -> Type
      -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))
getValueSafelyHook Hooks
hooks of
    Maybe
  (HscEnv
   -> Name
   -> Type
   -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))
Nothing -> Interp
-> HscEnv
-> Name
-> Type
-> IO (Either Type (HValue, [Linkable], PkgsLoaded))
getHValueSafely Interp
interp HscEnv
hsc_env Name
val_name Type
expected_type
    Just HscEnv
-> Name
-> Type
-> IO (Either Type (HValue, [Linkable], PkgsLoaded))
h  -> HscEnv
-> Name
-> Type
-> IO (Either Type (HValue, [Linkable], PkgsLoaded))
h                      HscEnv
hsc_env Name
val_name Type
expected_type
  case eith_hval of
    Left Type
actual_type -> Either Type (a, [Linkable], PkgsLoaded)
-> IO (Either Type (a, [Linkable], PkgsLoaded))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either Type (a, [Linkable], PkgsLoaded)
forall a b. a -> Either a b
Left Type
actual_type)
    Right (HValue
hval, [Linkable]
links, PkgsLoaded
pkgs) -> do
      value <- Logger -> CommandLineOption -> HValue -> IO a
forall a b. Logger -> CommandLineOption -> a -> IO b
lessUnsafeCoerce Logger
logger CommandLineOption
"getValueSafely" HValue
hval
      return (Right (value, links, pkgs))
  where
    interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    hooks :: Hooks
hooks  = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env

getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
getHValueSafely :: Interp
-> HscEnv
-> Name
-> Type
-> IO (Either Type (HValue, [Linkable], PkgsLoaded))
getHValueSafely Interp
interp HscEnv
hsc_env Name
val_name Type
expected_type = do
    HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface HscEnv
hsc_env (CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"contains a name used in an invocation of getHValueSafely") Name
val_name
    -- Now look up the names for the value and type constructor in the type environment
    mb_val_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
val_name
    case mb_val_thing of
        Maybe TyThing
Nothing -> DynFlags
-> SDoc -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))
-> SDoc -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$ Name -> SDoc
missingTyThingError Name
val_name
        Just (AnId Id
id) -> do
            -- Check the value type in the interface against the type recovered from the type constructor
            -- before finally casting the value to the type we assume corresponds to that constructor
            if Type
expected_type HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Id -> Type
idType Id
id
             then do
                -- Link in the module that contains the value, if it has such a module
                case Name -> Maybe (GenModule Unit)
nameModule_maybe Name
val_name of
                    Just GenModule Unit
mod -> do Interp -> HscEnv -> GenModule Unit -> IO ()
loadModule Interp
interp HscEnv
hsc_env GenModule Unit
mod
                                   () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe (GenModule Unit)
Nothing ->  () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                -- Find the value that we just linked in and cast it given that we have proved it's type
                hval <- do
                  (v, links, pkgs) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
loadName Interp
interp HscEnv
hsc_env Name
val_name
                  hv <- wormhole interp v
                  return (hv, links, pkgs)
                return (Right hval)
             else Either Type (HValue, [Linkable], PkgsLoaded)
-> IO (Either Type (HValue, [Linkable], PkgsLoaded))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either Type (HValue, [Linkable], PkgsLoaded)
forall a b. a -> Either a b
Left (Id -> Type
idType Id
id))
        Just TyThing
val_thing -> DynFlags
-> SDoc -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Either Type (HValue, [Linkable], PkgsLoaded)))
-> SDoc -> IO (Either Type (HValue, [Linkable], PkgsLoaded))
forall a b. (a -> b) -> a -> b
$ Name -> TyThing -> SDoc
wrongTyThingError Name
val_name TyThing
val_thing
   where dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

-- | Coerce a value as usual, but:
--
-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
--
-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
--    if it /does/ segfault
lessUnsafeCoerce :: Logger -> String -> a -> IO b
lessUnsafeCoerce :: forall a b. Logger -> CommandLineOption -> a -> IO b
lessUnsafeCoerce Logger
logger CommandLineOption
context a
what = do
    Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
        (CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Coercing a value in") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
context) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"...")
    output <- b -> IO b
forall a. a -> IO a
evaluate (a -> b
forall a b. a -> b
unsafeCoerce a
what)
    debugTraceMsg logger 3 (text "Successfully evaluated coercion")
    return output


-- | Finds the 'Name' corresponding to the given 'RdrName' in the
-- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
-- could be found. Any other condition results in an exception:
--
-- * If the module could not be found
-- * If we could not determine the imports of the module
--
-- Can only be used for looking up names while loading plugins (and is
-- *not* suitable for use within plugins).  The interface file is
-- loaded very partially: just enough that it can be used, without its
-- rules and instances affecting (and being linked from!) the module
-- being compiled.  This was introduced by 57d6798.
--
-- Need the module as well to record information in the interface file
lookupRdrNameInModuleForPlugins :: HasDebugCallStack
                                => HscEnv -> ModuleName -> RdrName
                                -> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins :: HasDebugCallStack =>
HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins HscEnv
hsc_env ModuleName
mod_name RdrName
rdr_name = do
    let dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let fopts :: FinderOpts
fopts      = DynFlags -> FinderOpts
initFinderOpts DynFlags
dflags
    let fc :: FinderCache
fc         = HscEnv -> FinderCache
hsc_FC HscEnv
hsc_env
    let unit_env :: UnitEnv
unit_env   = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
    let unit_state :: UnitState
unit_state = HasDebugCallStack => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units UnitEnv
unit_env
    let mhome_unit :: Maybe HomeUnit
mhome_unit = HscEnv -> Maybe HomeUnit
hsc_home_unit_maybe HscEnv
hsc_env
    -- First find the unit the module resides in by searching exposed units and home modules
    found_module <- FinderCache
-> FinderOpts
-> UnitState
-> Maybe HomeUnit
-> ModuleName
-> IO FindResult
findPluginModule FinderCache
fc FinderOpts
fopts UnitState
unit_state Maybe HomeUnit
mhome_unit ModuleName
mod_name
    case found_module of
        Found ModLocation
_ GenModule Unit
mod -> do
            -- Find the exports of the module
            (_, mb_iface) <- HscEnv -> TcM ModIface -> IO (Messages TcRnMessage, Maybe ModIface)
forall a. HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
initTcInteractive HscEnv
hsc_env (TcM ModIface -> IO (Messages TcRnMessage, Maybe ModIface))
-> TcM ModIface -> IO (Messages TcRnMessage, Maybe ModIface)
forall a b. (a -> b) -> a -> b
$
                             IOEnv (Env IfGblEnv ()) ModIface -> TcM ModIface
forall a. IfG a -> TcRn a
initIfaceTcRn (IOEnv (Env IfGblEnv ()) ModIface -> TcM ModIface)
-> IOEnv (Env IfGblEnv ()) ModIface -> TcM ModIface
forall a b. (a -> b) -> a -> b
$
                             SDoc -> GenModule Unit -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. SDoc -> GenModule Unit -> IfM lcl ModIface
loadPluginInterface SDoc
doc GenModule Unit
mod
            case mb_iface of
                Just ModIface
iface -> do
                    -- Try and find the required name in the exports
                    let decl_spec :: ImpDeclSpec
decl_spec = ImpDeclSpec { is_mod :: GenModule Unit
is_mod = GenModule Unit
mod, is_as :: ModuleName
is_as = ModuleName
mod_name, is_pkg_qual :: PkgQual
is_pkg_qual = PkgQual
NoPkgQual
                                                , is_qual :: Bool
is_qual = Bool
False, is_dloc :: SrcSpan
is_dloc = SrcSpan
noSrcSpan, is_isboot :: IsBootInterface
is_isboot = IsBootInterface
NotBoot }
                        imp_spec :: ImportSpec
imp_spec = ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec ImpDeclSpec
decl_spec ImpItemSpec
ImpAll
                        env :: GlobalRdrEnv
env = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv
                            ([GlobalRdrElt] -> GlobalRdrEnv) -> [GlobalRdrElt] -> GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails HscEnv
hsc_env (ImportSpec -> Maybe ImportSpec
forall a. a -> Maybe a
Just ImportSpec
imp_spec) (ModIface -> [AvailInfo]
forall (phase :: ModIfacePhase). ModIface_ phase -> [AvailInfo]
mi_exports ModIface
iface)
                    case GlobalRdrEnv -> LookupGRE GREInfo -> [GlobalRdrElt]
forall info.
GlobalRdrEnvX info -> LookupGRE info -> [GlobalRdrEltX info]
lookupGRE GlobalRdrEnv
env (RdrName -> WhichGREs GREInfo -> LookupGRE GREInfo
forall info. RdrName -> WhichGREs info -> LookupGRE info
LookupRdrName RdrName
rdr_name (FieldsOrSelectors -> WhichGREs GREInfo
RelevantGREsFOS FieldsOrSelectors
WantNormal)) of
                        [GlobalRdrElt
gre] -> Maybe (Name, ModIface) -> IO (Maybe (Name, ModIface))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name, ModIface) -> Maybe (Name, ModIface)
forall a. a -> Maybe a
Just (GlobalRdrElt -> Name
forall info. GlobalRdrEltX info -> Name
greName GlobalRdrElt
gre, ModIface
iface))
                        []    -> Maybe (Name, ModIface) -> IO (Maybe (Name, ModIface))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Name, ModIface)
forall a. Maybe a
Nothing
                        [GlobalRdrElt]
_     -> CommandLineOption -> IO (Maybe (Name, ModIface))
forall a. HasCallStack => CommandLineOption -> a
panic CommandLineOption
"lookupRdrNameInModule"

                Maybe ModIface
Nothing -> DynFlags -> SDoc -> IO (Maybe (Name, ModIface))
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Maybe (Name, ModIface)))
-> SDoc -> IO (Maybe (Name, ModIface))
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Could not determine the exports of the module", ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name]
        FindResult
err ->
          let opts :: DiagnosticOpts IfaceMessage
opts   = DynFlags -> DiagnosticOpts IfaceMessage
initIfaceMessageOpts DynFlags
dflags
              err_txt :: SDoc
err_txt = IfaceMessageOpts -> MissingInterfaceError -> SDoc
missingInterfaceErrorDiagnostic DiagnosticOpts IfaceMessage
IfaceMessageOpts
opts
                      (MissingInterfaceError -> SDoc) -> MissingInterfaceError -> SDoc
forall a b. (a -> b) -> a -> b
$ HscEnv -> ModuleName -> FindResult -> MissingInterfaceError
cannotFindModule HscEnv
hsc_env ModuleName
mod_name FindResult
err
          in DynFlags -> SDoc -> IO (Maybe (Name, ModIface))
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags SDoc
err_txt
  where
    doc :: SDoc
doc = CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"contains a name used in an invocation of lookupRdrNameInModule"

wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError Name
name TyThing
got_thing = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"The name", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"is not that of a value but rather a", TyThing -> SDoc
pprTyThingCategory TyThing
got_thing]

missingTyThingError :: Name -> SDoc
missingTyThingError :: Name -> SDoc
missingTyThingError Name
name = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"The name", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"is not in the type environment: are you sure it exists?"]

throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
throwCmdLineErrorS :: forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags = CommandLineOption -> IO a
forall a. CommandLineOption -> IO a
throwCmdLineError (CommandLineOption -> IO a)
-> (SDoc -> CommandLineOption) -> SDoc -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> SDoc -> CommandLineOption
showSDoc DynFlags
dflags

throwCmdLineError :: String -> IO a
throwCmdLineError :: forall a. CommandLineOption -> IO a
throwCmdLineError = GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO a)
-> (CommandLineOption -> GhcException) -> CommandLineOption -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> GhcException
CmdLineError