{-# LANGUAGE CPP #-}

-- | 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, hscInterp )
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.Unit.Module   ( Module, ModuleName )
import GHC.Unit.Module.ModIface

import GHC.Utils.Panic
import GHC.Utils.Logger
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception

import GHC.Data.FastString

import Control.Monad     ( unless )
import Data.Maybe        ( mapMaybe )
import Unsafe.Coerce     ( unsafeCoerce )

-- | 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 -> ModuleName) -> [LoadedPlugin] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map LoadedPlugin -> ModuleName
lpModuleName (HscEnv -> [LoadedPlugin]
hsc_plugins HscEnv
hsc_env) [ModuleName] -> [ModuleName] -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (HscEnv -> [LoadedPlugin]
hsc_plugins HscEnv
hsc_env)
  = HscEnv -> IO HscEnv
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env -- no need to reload plugins
  | Bool
otherwise
  = do [LoadedPlugin]
loaded_plugins <- HscEnv -> IO [LoadedPlugin]
loadPlugins HscEnv
hsc_env
       let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_plugins :: [LoadedPlugin]
hsc_plugins = [LoadedPlugin]
loaded_plugins }
       HscEnv -> PluginOperation IO HscEnv -> HscEnv -> IO HscEnv
forall (m :: * -> *) a.
Monad m =>
HscEnv -> PluginOperation m a -> a -> m a
withPlugins 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]
loadPlugins :: HscEnv -> IO [LoadedPlugin]
loadPlugins HscEnv
hsc_env
  = do { Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ModuleName] -> 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)]
plugins <- (ModuleName -> IO (Plugin, ModIface))
-> [ModuleName] -> IO [(Plugin, ModIface)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ModuleName -> IO (Plugin, ModIface)
loadPlugin [ModuleName]
to_load
       ; [LoadedPlugin] -> IO [LoadedPlugin]
forall (m :: * -> *) a. Monad m => a -> m a
return ([LoadedPlugin] -> IO [LoadedPlugin])
-> [LoadedPlugin] -> IO [LoadedPlugin]
forall a b. (a -> b) -> a -> b
$ (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)]
plugins }
  where
    dflags :: DynFlags
dflags  = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    to_load :: [ModuleName]
to_load = 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)
loadPlugin = OccName -> Name -> HscEnv -> ModuleName -> IO (Plugin, ModIface)
forall a.
OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
loadPlugin' (CommandLineOption -> OccName
mkVarOcc CommandLineOption
"plugin") Name
pluginTyConName HscEnv
hsc_env


loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
loadFrontendPlugin HscEnv
hsc_env ModuleName
mod_name = do
    HscEnv -> IO ()
checkExternalInterpreter HscEnv
hsc_env
    (FrontendPlugin, ModIface) -> FrontendPlugin
forall a b. (a, b) -> a
fst ((FrontendPlugin, ModIface) -> FrontendPlugin)
-> IO (FrontendPlugin, ModIface) -> IO FrontendPlugin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OccName
-> Name -> HscEnv -> ModuleName -> IO (FrontendPlugin, ModIface)
forall a.
OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
loadPlugin' (CommandLineOption -> OccName
mkVarOcc CommandLineOption
"frontendPlugin") Name
frontendPluginTyConName
                HscEnv
hsc_env ModuleName
mod_name

-- #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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
loadPlugin' :: forall a.
OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface)
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)
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
        ; Maybe a
mb_plugin <- HscEnv -> Name -> Type -> IO (Maybe a)
forall a. HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely HscEnv
hsc_env Name
name (TyCon -> Type
mkTyConTy TyCon
plugin_tycon)
        ; case Maybe a
mb_plugin of
            Maybe a
Nothing ->
                GhcException -> IO (a, ModIface)
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 value", Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
                          , CommandLineOption -> SDoc
text CommandLineOption
"did not have the type"
                          , Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
pluginTyConName, CommandLineOption -> SDoc
text CommandLineOption
"as required"])
            Just a
plugin -> (a, ModIface) -> IO (a, ModIface)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
plugin, ModIface
mod_iface) } } }


-- | 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 DecoratedSDoc, Maybe ())
forall a. HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
initTcInteractive HscEnv
hsc_env (TcM () -> IO (Messages DecoratedSDoc, Maybe ()))
-> TcM () -> IO (Messages DecoratedSDoc, 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 DecoratedSDoc, Maybe ()) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
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 (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 @Nothing@. 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 (Maybe a)
getValueSafely :: forall a. HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely HscEnv
hsc_env Name
val_name Type
expected_type = do
  Maybe HValue
mb_hval <- case Hooks -> Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
getValueSafelyHook Hooks
hooks of
    Maybe (HscEnv -> Name -> Type -> IO (Maybe HValue))
Nothing -> Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)
getHValueSafely Interp
interp HscEnv
hsc_env Name
val_name Type
expected_type
    Just HscEnv -> Name -> Type -> IO (Maybe HValue)
h  -> HscEnv -> Name -> Type -> IO (Maybe HValue)
h                      HscEnv
hsc_env Name
val_name Type
expected_type
  case Maybe HValue
mb_hval of
    Maybe HValue
Nothing   -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    Just HValue
hval -> do
      a
value <- Logger -> DynFlags -> CommandLineOption -> HValue -> IO a
forall a b. Logger -> DynFlags -> CommandLineOption -> a -> IO b
lessUnsafeCoerce Logger
logger DynFlags
dflags CommandLineOption
"getValueSafely" HValue
hval
      Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
value)
  where
    interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags 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 (Maybe HValue)
getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)
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 (Maybe HValue)
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Maybe HValue)) -> SDoc -> IO (Maybe HValue)
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 (m :: * -> *) a. Monad m => a -> m a
return ()
                    Maybe Module
Nothing ->  () -> IO ()
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
hval <- do
                  ForeignHValue
v <- Interp -> HscEnv -> Name -> IO ForeignHValue
loadName Interp
interp HscEnv
hsc_env Name
val_name
                  Interp -> ForeignHValue -> IO HValue
forall a. Interp -> ForeignRef a -> IO a
wormhole Interp
interp ForeignHValue
v
                Maybe HValue -> IO (Maybe HValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (HValue -> Maybe HValue
forall a. a -> Maybe a
Just HValue
hval)
             else Maybe HValue -> IO (Maybe HValue)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe HValue
forall a. Maybe a
Nothing
        Just TyThing
val_thing -> DynFlags -> SDoc -> IO (Maybe HValue)
forall a. DynFlags -> SDoc -> IO a
throwCmdLineErrorS DynFlags
dflags (SDoc -> IO (Maybe HValue)) -> SDoc -> IO (Maybe HValue)
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 -> DynFlags -> String -> a -> IO b
lessUnsafeCoerce :: forall a b. Logger -> DynFlags -> CommandLineOption -> a -> IO b
lessUnsafeCoerce Logger
logger DynFlags
dflags CommandLineOption
context a
what = do
    Logger -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags 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 -> DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger DynFlags
dflags Int
3 (CommandLineOption -> SDoc
text CommandLineOption
"Successfully evaluated coercion")
    b -> IO b
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
    -- First find the unit the module resides in by searching exposed units and home modules
    FindResult
found_module <- HscEnv -> ModuleName -> IO FindResult
findPluginModule HscEnv
hsc_env ModuleName
mod_name
    case FindResult
found_module of
        Found ModLocation
_ Module
mod -> do
            -- Find the exports of the module
            (Messages DecoratedSDoc
_, Maybe ModIface
mb_iface) <- HscEnv
-> TcM ModIface -> IO (Messages DecoratedSDoc, Maybe ModIface)
forall a. HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)
initTcInteractive HscEnv
hsc_env (TcM ModIface -> IO (Messages DecoratedSDoc, Maybe ModIface))
-> TcM ModIface -> IO (Messages DecoratedSDoc, 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 (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 (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
    dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    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, PtrString -> SDoc
ptext (CommandLineOption -> PtrString
sLit 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, PtrString -> SDoc
ptext (CommandLineOption -> PtrString
sLit 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