module DynamicLoading (
#ifdef GHCI
loadPlugins,
forceLoadModuleInterfaces,
forceLoadNameModuleInterface,
forceLoadTyCon,
lookupRdrNameInModuleForPlugins,
getValueSafely,
getHValueSafely,
lessUnsafeCoerce
#endif
) where
#ifdef GHCI
import Linker ( linkModule, getHValue )
import SrcLoc ( noSrcSpan )
import Finder ( findImportedModule, cannotFindModule )
import TcRnMonad ( initTcInteractive, initIfaceTcRn )
import LoadIface ( loadPluginInterface )
import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..)
, ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
, gre_name, mkRdrQual )
import OccName ( mkVarOcc )
import RnNames ( gresFromAvails )
import DynFlags
import Plugins ( Plugin, CommandLineOption )
import PrelNames ( pluginTyConName )
import HscTypes
import BasicTypes ( HValue )
import TypeRep ( mkTyConTy, pprTyThingCategory )
import Type ( Type, eqType )
import TyCon ( TyCon )
import Name ( Name, nameModule_maybe )
import Id ( idType )
import Module ( Module, ModuleName )
import Panic
import FastString
import ErrUtils
import Outputable
import Exception
import Hooks
import Data.Maybe ( mapMaybe )
import GHC.Exts ( unsafeCoerce# )
loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]
loadPlugins hsc_env
= do { plugins <- mapM (loadPlugin hsc_env) to_load
; return $ map attachOptions $ to_load `zip` plugins }
where
dflags = hsc_dflags hsc_env
to_load = pluginModNames dflags
attachOptions (mod_nm, plug) = (mod_nm, plug, options)
where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ]
loadPlugin :: HscEnv -> ModuleName -> IO Plugin
loadPlugin hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
dflags = hsc_dflags hsc_env
; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
plugin_rdr_name
; case mb_name of {
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The module"), ppr mod_name
, ptext (sLit "did not export the plugin name")
, ppr plugin_rdr_name ]) ;
Just name ->
do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
; case mb_plugin of
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The value"), ppr name
, ptext (sLit "did not have the type")
, ppr pluginTyConName, ptext (sLit "as required")])
Just plugin -> return plugin } } }
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
forceLoadModuleInterfaces hsc_env doc modules
= (initTcInteractive hsc_env $
initIfaceTcRn $
mapM_ (loadPluginInterface doc) modules)
>> return ()
forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
forceLoadNameModuleInterface hsc_env reason name = do
let name_modules = mapMaybe nameModule_maybe [name]
forceLoadModuleInterfaces hsc_env reason name_modules
forceLoadTyCon :: HscEnv -> Name -> IO TyCon
forceLoadTyCon hsc_env con_name = do
forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name
mb_con_thing <- lookupTypeHscEnv hsc_env con_name
case mb_con_thing of
Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
Just (ATyCon tycon) -> return tycon
Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
where dflags = hsc_dflags hsc_env
getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
getValueSafely hsc_env val_name expected_type = do
mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
case mb_hval of
Nothing -> return Nothing
Just hval -> do
value <- lessUnsafeCoerce dflags "getValueSafely" hval
return (Just value)
where
dflags = hsc_dflags hsc_env
getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
getHValueSafely hsc_env val_name expected_type = do
forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getHValueSafely")) val_name
mb_val_thing <- lookupTypeHscEnv hsc_env val_name
case mb_val_thing of
Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
Just (AnId id) -> do
if expected_type `eqType` idType id
then do
case nameModule_maybe val_name of
Just mod -> do linkModule hsc_env mod
return ()
Nothing -> return ()
hval <- getHValue hsc_env val_name
return (Just hval)
else return Nothing
Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
where dflags = hsc_dflags hsc_env
lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
lessUnsafeCoerce dflags context what = do
debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...")
output <- evaluate (unsafeCoerce# what)
debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion"
return output
lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
found_module <- findImportedModule hsc_env mod_name Nothing
case found_module of
Found _ mod -> do
(_, mb_iface) <- initTcInteractive hsc_env $
initIfaceTcRn $
loadPluginInterface doc mod
case mb_iface of
Just iface -> do
let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
, is_qual = False, is_dloc = noSrcSpan }
provenance = Imported [ImpSpec decl_spec ImpAll]
env = mkGlobalRdrEnv (gresFromAvails provenance (mi_exports iface))
case lookupGRE_RdrName rdr_name env of
[gre] -> return (Just (gre_name gre))
[] -> return Nothing
_ -> panic "lookupRdrNameInModule"
Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
where
dflags = hsc_dflags hsc_env
doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")
wrongTyThingError :: Name -> TyThing -> SDoc
wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]
missingTyThingError :: Name -> SDoc
missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
throwCmdLineError :: String -> IO a
throwCmdLineError = throwGhcExceptionIO . CmdLineError
#endif