Implement -hide-all-plugin-packages and -plugin-package(-id), fixing #11244
[ghc.git] / compiler / main / DynamicLoading.hs
1 {-# LANGUAGE CPP, MagicHash #-}
2
3 -- | Dynamically lookup up values from modules and loading them.
4 module DynamicLoading (
5 #ifdef GHCI
6 -- * Loading plugins
7 loadPlugins,
8 loadFrontendPlugin,
9
10 -- * Force loading information
11 forceLoadModuleInterfaces,
12 forceLoadNameModuleInterface,
13 forceLoadTyCon,
14
15 -- * Finding names
16 lookupRdrNameInModuleForPlugins,
17
18 -- * Loading values
19 getValueSafely,
20 getHValueSafely,
21 lessUnsafeCoerce
22 #endif
23 ) where
24
25 #ifdef GHCI
26 import Linker ( linkModule, getHValue )
27 import GHCi ( wormhole )
28 import SrcLoc ( noSrcSpan )
29 import Finder ( findPluginModule, cannotFindModule )
30 import TcRnMonad ( initTcInteractive, initIfaceTcRn )
31 import LoadIface ( loadPluginInterface )
32 import RdrName ( RdrName, ImportSpec(..), ImpDeclSpec(..)
33 , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
34 , gre_name, mkRdrQual )
35 import OccName ( OccName, mkVarOcc )
36 import RnNames ( gresFromAvails )
37 import DynFlags
38 import Plugins ( Plugin, FrontendPlugin, CommandLineOption )
39 import PrelNames ( pluginTyConName, frontendPluginTyConName )
40
41 import HscTypes
42 import GHCi.RemoteTypes ( HValue )
43 import Type ( Type, eqType, mkTyConTy, pprTyThingCategory )
44 import TyCon ( TyCon )
45 import Name ( Name, nameModule_maybe )
46 import Id ( idType )
47 import Module ( Module, ModuleName )
48 import Panic
49 import FastString
50 import ErrUtils
51 import Outputable
52 import Exception
53 import Hooks
54
55 import Data.Maybe ( mapMaybe )
56 import GHC.Exts ( unsafeCoerce# )
57
58
59 loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]
60 loadPlugins hsc_env
61 = do { plugins <- mapM (loadPlugin hsc_env) to_load
62 ; return $ map attachOptions $ to_load `zip` plugins }
63 where
64 dflags = hsc_dflags hsc_env
65 to_load = pluginModNames dflags
66
67 attachOptions (mod_nm, plug) = (mod_nm, plug, options)
68 where
69 options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
70 , opt_mod_nm == mod_nm ]
71
72 loadPlugin :: HscEnv -> ModuleName -> IO Plugin
73 loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName
74
75 loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
76 loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
77
78 loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a
79 loadPlugin' occ_name plugin_name hsc_env mod_name
80 = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
81 dflags = hsc_dflags hsc_env
82 ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
83 plugin_rdr_name
84 ; case mb_name of {
85 Nothing ->
86 throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
87 [ ptext (sLit "The module"), ppr mod_name
88 , ptext (sLit "did not export the plugin name")
89 , ppr plugin_rdr_name ]) ;
90 Just name ->
91
92 do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
93 ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
94 ; case mb_plugin of
95 Nothing ->
96 throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
97 [ ptext (sLit "The value"), ppr name
98 , ptext (sLit "did not have the type")
99 , ppr pluginTyConName, ptext (sLit "as required")])
100 Just plugin -> return plugin } } }
101
102
103 -- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
104 -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
105 forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
106 forceLoadModuleInterfaces hsc_env doc modules
107 = (initTcInteractive hsc_env $
108 initIfaceTcRn $
109 mapM_ (loadPluginInterface doc) modules)
110 >> return ()
111
112 -- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used
113 -- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
114 forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO ()
115 forceLoadNameModuleInterface hsc_env reason name = do
116 let name_modules = mapMaybe nameModule_maybe [name]
117 forceLoadModuleInterfaces hsc_env reason name_modules
118
119 -- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if:
120 --
121 -- * The interface could not be loaded
122 -- * The name is not that of a 'TyCon'
123 -- * The name did not exist in the loaded module
124 forceLoadTyCon :: HscEnv -> Name -> IO TyCon
125 forceLoadTyCon hsc_env con_name = do
126 forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name
127
128 mb_con_thing <- lookupTypeHscEnv hsc_env con_name
129 case mb_con_thing of
130 Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name
131 Just (ATyCon tycon) -> return tycon
132 Just con_thing -> throwCmdLineErrorS dflags $ wrongTyThingError con_name con_thing
133 where dflags = hsc_dflags hsc_env
134
135 -- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety
136 -- 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!
137 --
138 -- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception:
139 --
140 -- * If we could not load the names module
141 -- * If the thing being loaded is not a value
142 -- * If the Name does not exist in the module
143 -- * If the link failed
144
145 getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a)
146 getValueSafely hsc_env val_name expected_type = do
147 mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type
148 case mb_hval of
149 Nothing -> return Nothing
150 Just hval -> do
151 value <- lessUnsafeCoerce dflags "getValueSafely" hval
152 return (Just value)
153 where
154 dflags = hsc_dflags hsc_env
155
156 getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)
157 getHValueSafely hsc_env val_name expected_type = do
158 forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getHValueSafely")) val_name
159 -- Now look up the names for the value and type constructor in the type environment
160 mb_val_thing <- lookupTypeHscEnv hsc_env val_name
161 case mb_val_thing of
162 Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name
163 Just (AnId id) -> do
164 -- Check the value type in the interface against the type recovered from the type constructor
165 -- before finally casting the value to the type we assume corresponds to that constructor
166 if expected_type `eqType` idType id
167 then do
168 -- Link in the module that contains the value, if it has such a module
169 case nameModule_maybe val_name of
170 Just mod -> do linkModule hsc_env mod
171 return ()
172 Nothing -> return ()
173 -- Find the value that we just linked in and cast it given that we have proved it's type
174 hval <- getHValue hsc_env val_name >>= wormhole dflags
175 return (Just hval)
176 else return Nothing
177 Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing
178 where dflags = hsc_dflags hsc_env
179
180 -- | Coerce a value as usual, but:
181 --
182 -- 1) Evaluate it immediately to get a segfault early if the coercion was wrong
183 --
184 -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened
185 -- if it /does/ segfault
186 lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
187 lessUnsafeCoerce dflags context what = do
188 debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...")
189 output <- evaluate (unsafeCoerce# what)
190 debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion"
191 return output
192
193
194 -- | Finds the 'Name' corresponding to the given 'RdrName' in the
195 -- context of the 'ModuleName'. Returns @Nothing@ if no such 'Name'
196 -- could be found. Any other condition results in an exception:
197 --
198 -- * If the module could not be found
199 -- * If we could not determine the imports of the module
200 --
201 -- Can only be used for looking up names while loading plugins (and is
202 -- *not* suitable for use within plugins). The interface file is
203 -- loaded very partially: just enough that it can be used, without its
204 -- rules and instances affecting (and being linked from!) the module
205 -- being compiled. This was introduced by 57d6798.
206 lookupRdrNameInModuleForPlugins :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name)
207 lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do
208 -- First find the package the module resides in by searching exposed packages and home modules
209 found_module <- findPluginModule hsc_env mod_name
210 case found_module of
211 Found _ mod -> do
212 -- Find the exports of the module
213 (_, mb_iface) <- initTcInteractive hsc_env $
214 initIfaceTcRn $
215 loadPluginInterface doc mod
216 case mb_iface of
217 Just iface -> do
218 -- Try and find the required name in the exports
219 let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name
220 , is_qual = False, is_dloc = noSrcSpan }
221 imp_spec = ImpSpec decl_spec ImpAll
222 env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))
223 case lookupGRE_RdrName rdr_name env of
224 [gre] -> return (Just (gre_name gre))
225 [] -> return Nothing
226 _ -> panic "lookupRdrNameInModule"
227
228 Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name]
229 err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err
230 where
231 dflags = hsc_dflags hsc_env
232 doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule")
233
234 wrongTyThingError :: Name -> TyThing -> SDoc
235 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]
236
237 missingTyThingError :: Name -> SDoc
238 missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]
239
240 throwCmdLineErrorS :: DynFlags -> SDoc -> IO a
241 throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
242
243 throwCmdLineError :: String -> IO a
244 throwCmdLineError = throwGhcExceptionIO . CmdLineError
245 #endif