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

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

        -- * Finding names
        lookupRdrNameInModuleForPlugins,

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

import GHC.Prelude

import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Hooks
import GHC.Driver.Plugins

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

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

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

import GHC.Types.SrcLoc        ( noSrcSpan )
import GHC.Types.Name    ( Name, nameModule_maybe )
import GHC.Types.Id      ( idType )
import GHC.Types.TyThing
import GHC.Types.Name.Occurrence ( OccName, mkVarOcc )
import GHC.Types.Name.Reader   ( RdrName, ImportSpec(..), ImpDeclSpec(..)
                               , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
                               , greMangledName, mkRdrQual )

import GHC.Unit.Finder         ( findPluginModule, FindResult(..) )
import GHC.Driver.Config.Finder ( initFinderOpts )
import GHC.Unit.Module   ( Module, ModuleName )
import GHC.Unit.Module.ModIface
import GHC.Unit.Env

import GHC.Utils.Panic
import GHC.Utils.Logger
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 GHC.Types.Unique.DFM
import Data.List (unzip4)

-- | 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
    -- plugins not changed
  | [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)
   -- arguments not changed
  , (LoadedPlugin -> Bool) -> [LoadedPlugin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LoadedPlugin -> Bool
same_args [LoadedPlugin]
loaded_plugins
  = HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env -- no need to reload plugins FIXME: doesn't take static plugins into account
  | Bool
otherwise
  = do ([LoadedPlugin]
loaded_plugins, [Linkable]
links, PkgsLoaded
pkgs) <- HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
loadPlugins HscEnv
hsc_env
       let plugins' :: Plugins
plugins' = (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) { loadedPlugins :: [LoadedPlugin]
loadedPlugins = [LoadedPlugin]
loaded_plugins, loadedPluginDeps :: ([Linkable], PkgsLoaded)
loadedPluginDeps = ([Linkable]
links, PkgsLoaded
pkgs) }
       let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_plugins :: Plugins
hsc_plugins = Plugins
plugins' }
       Plugins -> PluginOperation IO HscEnv -> HscEnv -> IO HscEnv
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env') PluginOperation IO HscEnv
driverPlugin HscEnv
hsc_env'
  where
    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)
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env

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
       ; [(Plugin, ModIface, [Linkable], PkgsLoaded)]
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 ([Plugin]
plugins, [ModIface]
ifaces, [[Linkable]]
links, [PkgsLoaded]
pkgs) = [(Plugin, ModIface, [Linkable], PkgsLoaded)]
-> ([Plugin], [ModIface], [[Linkable]], [PkgsLoaded])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [(Plugin, ModIface, [Linkable], PkgsLoaded)]
plugins_with_deps
       ; ([LoadedPlugin], [Linkable], PkgsLoaded)
-> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((ModuleName -> (Plugin, ModIface) -> LoadedPlugin)
-> [ModuleName] -> [(Plugin, ModIface)] -> [LoadedPlugin]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ModuleName -> (Plugin, ModIface) -> LoadedPlugin
attachOptions [ModuleName]
to_load ([Plugin] -> [ModIface] -> [(Plugin, ModIface)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Plugin]
plugins [ModIface]
ifaces), [[Linkable]] -> [Linkable]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Linkable]]
links, (PkgsLoaded -> PkgsLoaded -> PkgsLoaded)
-> PkgsLoaded -> [PkgsLoaded] -> PkgsLoaded
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PkgsLoaded -> PkgsLoaded -> PkgsLoaded
forall key elt.
UniqDFM key elt -> UniqDFM key elt -> UniqDFM key elt
plusUDFM PkgsLoaded
forall key elt. UniqDFM key elt
emptyUDFM [PkgsLoaded]
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' (CommandLineOption -> OccName
mkVarOcc 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
    (FrontendPlugin
plugin, ModIface
_iface, [Linkable]
links, PkgsLoaded
pkgs)
      <- OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (FrontendPlugin, ModIface, [Linkable], PkgsLoaded)
forall a.
OccName
-> Name
-> HscEnv
-> ModuleName
-> IO (a, ModIface, [Linkable], PkgsLoaded)
loadPlugin' (CommandLineOption -> OccName
mkVarOcc CommandLineOption
"frontendPlugin") Name
frontendPluginTyConName
           HscEnv
hsc_env ModuleName
mod_name
    (FrontendPlugin, [Linkable], PkgsLoaded)
-> IO (FrontendPlugin, [Linkable], PkgsLoaded)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FrontendPlugin
plugin, [Linkable]
links, PkgsLoaded
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. 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
       ; Maybe (Name, ModIface)
mb_name <- HscEnv -> ModuleName -> RdrName -> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins HscEnv
hsc_env ModuleName
mod_name
                        RdrName
plugin_rdr_name
       ; case Maybe (Name, ModIface)
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
hsep
                          [ CommandLineOption -> SDoc
text CommandLineOption
"The module", ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name
                          , CommandLineOption -> SDoc
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 { TyCon
plugin_tycon <- HscEnv -> Name -> IO TyCon
forceLoadTyCon HscEnv
hsc_env Name
plugin_name
        ; Either Type (a, [Linkable], PkgsLoaded)
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 Either Type (a, [Linkable], PkgsLoaded)
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 -> PrintUnqualified -> SDoc -> CommandLineOption
showSDocForUser DynFlags
dflags ((() :: Constraint) => UnitEnv -> UnitState
UnitEnv -> UnitState
ue_units (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env))
                      PrintUnqualified
alwaysQualify (SDoc -> CommandLineOption) -> SDoc -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
hsep
                          [ CommandLineOption -> SDoc
text CommandLineOption
"The value", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                          , CommandLineOption -> SDoc
text CommandLineOption
"with type", Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
actual_type
                          , CommandLineOption -> SDoc
text CommandLineOption
"did not have the type"
                          , CommandLineOption -> SDoc
text CommandLineOption
"GHC.Plugins.Plugin"
                          , CommandLineOption -> SDoc
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 -> [Module] -> IO ()
forceLoadModuleInterfaces HscEnv
hsc_env SDoc
doc [Module]
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
$
       (Module -> IOEnv (Env IfGblEnv ()) ModIface) -> [Module] -> IfG ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SDoc -> Module -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadPluginInterface SDoc
doc) [Module]
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 :: [Module]
name_modules = (Name -> Maybe Module) -> [Name] -> [Module]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Name -> Maybe Module
nameModule_maybe [Name
name]
    HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces HscEnv
hsc_env SDoc
reason [Module]
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
text CommandLineOption
"contains a name used in an invocation of loadTyConTy") Name
con_name

    Maybe TyThing
mb_con_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
con_name
    case Maybe TyThing
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
  Either Type (HValue, [Linkable], PkgsLoaded)
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 Either Type (HValue, [Linkable], PkgsLoaded)
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
      a
value <- Logger -> CommandLineOption -> HValue -> IO a
forall a b. Logger -> CommandLineOption -> a -> IO b
lessUnsafeCoerce Logger
logger CommandLineOption
"getValueSafely" HValue
hval
      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 ((a, [Linkable], PkgsLoaded)
-> Either Type (a, [Linkable], PkgsLoaded)
forall a b. b -> Either a b
Right (a
value, [Linkable]
links, PkgsLoaded
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
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
    Maybe TyThing
mb_val_thing <- HscEnv -> Name -> IO (Maybe TyThing)
lookupType HscEnv
hsc_env Name
val_name
    case Maybe TyThing
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 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 Module
nameModule_maybe Name
val_name of
                    Just Module
mod -> do Interp -> HscEnv -> Module -> IO ()
loadModule Interp
interp HscEnv
hsc_env Module
mod
                                   () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe Module
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
                (HValue, [Linkable], PkgsLoaded)
hval <- do
                  (ForeignHValue
v, [Linkable]
links, PkgsLoaded
pkgs) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
loadName Interp
interp HscEnv
hsc_env Name
val_name
                  HValue
hv <- Interp -> ForeignHValue -> IO HValue
forall a. Interp -> ForeignRef a -> IO a
wormhole Interp
interp ForeignHValue
v
                  (HValue, [Linkable], PkgsLoaded)
-> IO (HValue, [Linkable], PkgsLoaded)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HValue
hv, [Linkable]
links, PkgsLoaded
pkgs)
                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 ((HValue, [Linkable], PkgsLoaded)
-> Either Type (HValue, [Linkable], PkgsLoaded)
forall a b. b -> Either a b
Right (HValue, [Linkable], PkgsLoaded)
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
text CommandLineOption
"Coercing a value in") SDoc -> SDoc -> SDoc
<+> (CommandLineOption -> SDoc
text CommandLineOption
context) SDoc -> SDoc -> SDoc
<> (CommandLineOption -> SDoc
text CommandLineOption
"...")
    b
output <- b -> IO b
forall a. a -> IO a
evaluate (a -> b
forall a b. a -> b
unsafeCoerce a
what)
    Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
3 (CommandLineOption -> SDoc
text CommandLineOption
"Successfully evaluated coercion")
    b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
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 :: HscEnv -> ModuleName -> RdrName
                                -> IO (Maybe (Name, ModIface))
lookupRdrNameInModuleForPlugins :: 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 = (() :: Constraint) => 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
    FindResult
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 FindResult
found_module of
        Found ModLocation
_ Module
mod -> do
            -- Find the exports of the module
            (Messages TcRnMessage
_, Maybe ModIface
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 -> Module -> IOEnv (Env IfGblEnv ()) ModIface
forall lcl. SDoc -> Module -> IfM lcl ModIface
loadPluginInterface SDoc
doc Module
mod
            case Maybe ModIface
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 :: ModuleName
is_mod = ModuleName
mod_name, is_as :: ModuleName
is_as = ModuleName
mod_name
                                                , is_qual :: Bool
is_qual = Bool
False, is_dloc :: SrcSpan
is_dloc = SrcSpan
noSrcSpan }
                        imp_spec :: ImportSpec
imp_spec = ImpDeclSpec -> ImpItemSpec -> ImportSpec
ImpSpec ImpDeclSpec
decl_spec ImpItemSpec
ImpAll
                        env :: GlobalRdrEnv
env = [GlobalRdrElt] -> GlobalRdrEnv
mkGlobalRdrEnv (Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt]
gresFromAvails (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 RdrName -> GlobalRdrEnv -> [GlobalRdrElt]
lookupGRE_RdrName RdrName
rdr_name GlobalRdrEnv
env 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
greMangledName 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. 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
hsep [CommandLineOption -> SDoc
text CommandLineOption
"Could not determine the exports of the module", ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
mod_name]
        FindResult
err -> 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
$ HscEnv -> ModuleName -> FindResult -> SDoc
cannotFindModule HscEnv
hsc_env ModuleName
mod_name FindResult
err
  where
    doc :: SDoc
doc = CommandLineOption -> SDoc
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
hsep [CommandLineOption -> SDoc
text CommandLineOption
"The name", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, CommandLineOption -> SDoc
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
hsep [CommandLineOption -> SDoc
text CommandLineOption
"The name", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name, CommandLineOption -> SDoc
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