module GHC.Runtime.Loader (
initializePlugins, initializeSessionPlugins,
loadFrontendPlugin,
forceLoadModuleInterfaces,
forceLoadNameModuleInterface,
forceLoadTyCon,
lookupRdrNameInModuleForPlugins,
getValueSafely,
getHValueSafely,
lessUnsafeCoerce
) where
import GHC.Prelude
import GHC.Data.FastString
import GHC.Driver.Session
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.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, mkTyConTy )
import GHC.Core.TyCo.Compare( eqType )
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, mkVarOccFS )
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)
import GHC.Driver.Monad
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
initializePlugins :: HscEnv -> IO HscEnv
initializePlugins :: HscEnv -> IO HscEnv
initializePlugins HscEnv
hsc_env
| [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
, [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)
= HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
| Bool
otherwise
= do ([LoadedPlugin]
loaded_plugins, [Linkable]
links, PkgsLoaded
pkgs) <- HscEnv -> IO ([LoadedPlugin], [Linkable], PkgsLoaded)
loadPlugins HscEnv
hsc_env
[ExternalPlugin]
external_plugins <- [ExternalPluginSpec] -> IO [ExternalPlugin]
loadExternalPlugins (DynFlags -> [ExternalPluginSpec]
externalPluginSpecs DynFlags
dflags)
let plugins' :: Plugins
plugins' = (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) { staticPlugins = staticPlugins (hsc_plugins hsc_env)
, externalPlugins = external_plugins
, loadedPlugins = loaded_plugins
, loadedPluginDeps = (links, pkgs)
}
let hsc_env' :: HscEnv
hsc_env' = HscEnv
hsc_env { hsc_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
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
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)
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
([] , [ExternalPluginSpec]
_ ) -> Bool
False
(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
; [(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' (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
(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' (FastString -> OccName
mkVarOccFS (CommandLineOption -> FastString
fsLit 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)
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
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 { 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 -> NamePprCtx -> SDoc -> CommandLineOption
showSDocForUser DynFlags
dflags ((() :: Constraint) => 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) } } }
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 ()
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
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
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
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
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"contains a name used in an invocation of getHValueSafely") Name
val_name
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
if Type
expected_type Type -> Type -> Bool
`eqType` Id -> Type
idType Id
id
then do
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 ()
(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
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
"...")
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
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Successfully evaluated coercion")
b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return b
output
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
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
(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
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. 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 -> 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
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