Commit e0eb7e7d authored by dterei's avatar dterei

SafeHaskell: Add ':issafe' cmd to GHCi that displays module safety info

parent f04bbfdb
......@@ -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
......
......@@ -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" ++
......@@ -1317,6 +1319,51 @@ runScript filename = do
then scriptLoop script
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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment