diff options
| -rw-r--r-- | compiler/main/GHC.hs | 52 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 49 |
2 files changed, 80 insertions, 21 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index dc297a0051..1c9a8917fb 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -67,9 +67,11 @@ module GHC ( modInfoInstances, modInfoIsExportedName, modInfoLookupName, + modInfoIface, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, + ModIface(..), -- * Querying the environment packageDbModules, @@ -603,7 +605,7 @@ instance ParsedMod TypecheckedModule where instance TypecheckedMod TypecheckedModule where renamedSource m = tm_renamed_source m typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m + moduleInfo m = tm_checked_module_info m tm_internals m = tm_internals_ m -- | The result of successful desugaring (i.e., translation to core). Also @@ -691,9 +693,10 @@ typecheckModule pmod = do minf_type_env = md_types details, minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = md_insts details + minf_instances = md_insts details, + minf_iface = Nothing #ifdef GHCI - ,minf_modBreaks = emptyModBreaks + ,minf_modBreaks = emptyModBreaks #endif }} @@ -910,11 +913,11 @@ data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance] + minf_instances :: [Instance], + minf_iface :: Maybe ModIface #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif - -- ToDo: this should really contain the ModIface too } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -924,15 +927,8 @@ getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X getModuleInfo mdl = withSession $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) - else do - {- if isHomeModule (hsc_dflags hsc_env) mdl - then return Nothing - else -} liftIO $ getPackageModuleInfo hsc_env mdl - -- getPackageModuleInfo will attempt to find the interface, so - -- we don't want to call it for a home module, just in case there - -- was a problem loading the module and the interface doesn't - -- exist... hence the isHomeModule test here. (ToDo: reinstate) + then liftIO $ getHomeModuleInfo hsc_env mdl + else liftIO $ getPackageModuleInfo hsc_env mdl getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI @@ -945,7 +941,8 @@ getPackageModuleInfo hsc_env mdl = do case mb_avails of Nothing -> return Nothing Just avails -> do - eps <- readIORef (hsc_EPS hsc_env) + eps <- hscEPS hsc_env + iface <- lookupModuleIface hsc_env mdl let names = availsToNameSet avails pte = eps_PTE eps @@ -957,30 +954,42 @@ getPackageModuleInfo hsc_env mdl = do minf_exports = names, minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = iface, minf_modBreaks = emptyModBreaks })) #else +-- bogusly different for non-GHCI (ToDo) getPackageModuleInfo _hsc_env _mdl = do - -- bogusly different for non-GHCI (ToDo) return Nothing #endif -getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = - case lookupUFM (hsc_HPT hsc_env) mdl of + case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi + iface <- lookupModuleIface hsc_env mdl return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details + minf_instances = md_insts details, + minf_iface = iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif })) +lookupModuleIface :: HscEnv -> Module -> IO (Maybe ModIface) +lookupModuleIface env m = do + eps <- hscEPS env + let dflags = hsc_dflags env + pkgIfaceT = eps_PIT eps + homePkgT = hsc_HPT env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m + return iface + -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] modInfoTyThings minf = typeEnvElts (minf_type_env minf) @@ -1017,6 +1026,9 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 8b4422e487..ecf8095d23 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -34,7 +34,7 @@ import Packages -- import PackageConfig import UniqFM -import HscTypes ( handleFlagWarnings ) +import HscTypes ( handleFlagWarnings, getSafeMode ) import HsImpExp import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import RdrName (RdrName) @@ -134,6 +134,7 @@ builtin_commands = [ ("help", keepGoing help, noCompletion), ("history", keepGoing historyCmd, noCompletion), ("info", keepGoing' info, completeIdentifier), + ("issafe", keepGoing' isSafeCmd, completeModule), ("kind", keepGoing' kindOfType, completeIdentifier), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("list", keepGoing' listCmd, noCompletion), @@ -211,6 +212,7 @@ helpText = " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++ " :help, :? display this list of commands\n" ++ " :info [<name> ...] display information about the given names\n" ++ + " :issafe [<mod>] display safe haskell information of module <mod>\n" ++ " :kind <type> show the kind of <type>\n" ++ " :load [*]<module> ... load module(s) and their dependents\n" ++ " :main [<arguments> ...] run the main function with the given arguments\n" ++ @@ -1318,6 +1320,51 @@ runScript filename = do else return () ----------------------------------------------------------------------------- +-- Displaying SafeHaskell properties of a module + +isSafeCmd :: String -> InputT GHCi () +isSafeCmd m = + case words m of + [s] | looksLikeModuleName s -> do + m <- lift $ lookupModule s + isSafeModule m + [] -> do + (as,bs) <- GHC.getContext + -- Guess which module the user wants to browse. Pick + -- modules that are interpreted first. The most + -- recently-added module occurs last, it seems. + case (as,bs) of + (as@(_:_), _) -> isSafeModule $ last as + ([], bs@(_:_)) -> isSafeModule $ fst (last bs) + ([], []) -> ghcError (CmdLineError ":issafe: no current module") + _ -> ghcError (CmdLineError "syntax: :issafe <module>") + +isSafeModule :: Module -> InputT GHCi () +isSafeModule m = do + mb_mod_info <- GHC.getModuleInfo m + case mb_mod_info of + Nothing -> ghcError $ CmdLineError ("unknown module: " ++ + GHC.moduleNameString (GHC.moduleName m)) + Just mi -> do + dflags <- getDynFlags + let iface = GHC.modInfoIface mi + case iface of + Just iface' -> do + let trust = show $ getSafeMode $ GHC.mi_trust iface' + pkg = if packageTrusted dflags m then "trusted" else "untrusted" + liftIO $ putStrLn $ "Trust type is (Module: " ++ trust + ++ ", Package: " ++ pkg ++ ")" + Nothing -> ghcError $ CmdLineError ("can't load interface file for module: " ++ + GHC.moduleNameString (GHC.moduleName m)) + where + packageTrusted :: DynFlags -> Module -> Bool + packageTrusted dflags m + | thisPackage dflags == modulePackageId m = True + | otherwise = trusted $ getPackageDetails (pkgState dflags) + (modulePackageId m) + + +----------------------------------------------------------------------------- -- Browsing a module's contents browseCmd :: Bool -> String -> InputT GHCi () |