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 ( ...@@ -67,9 +67,11 @@ module GHC (
modInfoInstances, modInfoInstances,
modInfoIsExportedName, modInfoIsExportedName,
modInfoLookupName, modInfoLookupName,
modInfoIface,
lookupGlobalName, lookupGlobalName,
findGlobalAnns, findGlobalAnns,
mkPrintUnqualifiedForModule, mkPrintUnqualifiedForModule,
ModIface(..),
-- * Querying the environment -- * Querying the environment
packageDbModules, packageDbModules,
...@@ -603,7 +605,7 @@ instance ParsedMod TypecheckedModule where ...@@ -603,7 +605,7 @@ instance ParsedMod TypecheckedModule where
instance TypecheckedMod TypecheckedModule where instance TypecheckedMod TypecheckedModule where
renamedSource m = tm_renamed_source m renamedSource m = tm_renamed_source m
typecheckedSource m = tm_typechecked_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 tm_internals m = tm_internals_ m
-- | The result of successful desugaring (i.e., translation to core). Also -- | The result of successful desugaring (i.e., translation to core). Also
...@@ -691,9 +693,10 @@ typecheckModule pmod = do ...@@ -691,9 +693,10 @@ typecheckModule pmod = do
minf_type_env = md_types details, minf_type_env = md_types details,
minf_exports = availsToNameSet $ md_exports details, minf_exports = availsToNameSet $ md_exports details,
minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), 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 #ifdef GHCI
,minf_modBreaks = emptyModBreaks ,minf_modBreaks = emptyModBreaks
#endif #endif
}} }}
...@@ -910,11 +913,11 @@ data ModuleInfo = ModuleInfo { ...@@ -910,11 +913,11 @@ data ModuleInfo = ModuleInfo {
minf_type_env :: TypeEnv, minf_type_env :: TypeEnv,
minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails?
minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod
minf_instances :: [Instance] minf_instances :: [Instance],
minf_iface :: Maybe ModIface
#ifdef GHCI #ifdef GHCI
,minf_modBreaks :: ModBreaks ,minf_modBreaks :: ModBreaks
#endif #endif
-- ToDo: this should really contain the ModIface too
} }
-- We don't want HomeModInfo here, because a ModuleInfo applies -- We don't want HomeModInfo here, because a ModuleInfo applies
-- to package modules too. -- to package modules too.
...@@ -924,15 +927,8 @@ getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X ...@@ -924,15 +927,8 @@ getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo) -- XXX: Maybe X
getModuleInfo mdl = withSession $ \hsc_env -> do getModuleInfo mdl = withSession $ \hsc_env -> do
let mg = hsc_mod_graph hsc_env let mg = hsc_mod_graph hsc_env
if mdl `elem` map ms_mod mg if mdl `elem` map ms_mod mg
then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) then liftIO $ getHomeModuleInfo hsc_env mdl
else do else liftIO $ getPackageModuleInfo hsc_env mdl
{- 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)
getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
#ifdef GHCI #ifdef GHCI
...@@ -945,7 +941,8 @@ getPackageModuleInfo hsc_env mdl = do ...@@ -945,7 +941,8 @@ getPackageModuleInfo hsc_env mdl = do
case mb_avails of case mb_avails of
Nothing -> return Nothing Nothing -> return Nothing
Just avails -> do Just avails -> do
eps <- readIORef (hsc_EPS hsc_env) eps <- hscEPS hsc_env
iface <- lookupModuleIface hsc_env mdl
let let
names = availsToNameSet avails names = availsToNameSet avails
pte = eps_PTE eps pte = eps_PTE eps
...@@ -957,30 +954,42 @@ getPackageModuleInfo hsc_env mdl = do ...@@ -957,30 +954,42 @@ getPackageModuleInfo hsc_env mdl = do
minf_exports = names, minf_exports = names,
minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,
minf_instances = error "getModuleInfo: instances for package module unimplemented", minf_instances = error "getModuleInfo: instances for package module unimplemented",
minf_iface = iface,
minf_modBreaks = emptyModBreaks minf_modBreaks = emptyModBreaks
})) }))
#else #else
-- bogusly different for non-GHCI (ToDo)
getPackageModuleInfo _hsc_env _mdl = do getPackageModuleInfo _hsc_env _mdl = do
-- bogusly different for non-GHCI (ToDo)
return Nothing return Nothing
#endif #endif
getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
getHomeModuleInfo hsc_env mdl = getHomeModuleInfo hsc_env mdl =
case lookupUFM (hsc_HPT hsc_env) mdl of case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of
Nothing -> return Nothing Nothing -> return Nothing
Just hmi -> do Just hmi -> do
let details = hm_details hmi let details = hm_details hmi
iface <- lookupModuleIface hsc_env mdl
return (Just (ModuleInfo { return (Just (ModuleInfo {
minf_type_env = md_types details, minf_type_env = md_types details,
minf_exports = availsToNameSet (md_exports details), minf_exports = availsToNameSet (md_exports details),
minf_rdr_env = mi_globals $! hm_iface hmi, minf_rdr_env = mi_globals $! hm_iface hmi,
minf_instances = md_insts details minf_instances = md_insts details,
minf_iface = iface
#ifdef GHCI #ifdef GHCI
,minf_modBreaks = getModBreaks hmi ,minf_modBreaks = getModBreaks hmi
#endif #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 -- | The list of top-level entities defined in a module
modInfoTyThings :: ModuleInfo -> [TyThing] modInfoTyThings :: ModuleInfo -> [TyThing]
modInfoTyThings minf = typeEnvElts (minf_type_env minf) modInfoTyThings minf = typeEnvElts (minf_type_env minf)
...@@ -1017,6 +1026,9 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do ...@@ -1017,6 +1026,9 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do
return $! lookupType (hsc_dflags hsc_env) return $! lookupType (hsc_dflags hsc_env)
(hsc_HPT hsc_env) (eps_PTE eps) name (hsc_HPT hsc_env) (eps_PTE eps) name
modInfoIface :: ModuleInfo -> Maybe ModIface
modInfoIface = minf_iface
#ifdef GHCI #ifdef GHCI
modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks :: ModuleInfo -> ModBreaks
modInfoModBreaks = minf_modBreaks modInfoModBreaks = minf_modBreaks
......
...@@ -34,7 +34,7 @@ import Packages ...@@ -34,7 +34,7 @@ import Packages
-- import PackageConfig -- import PackageConfig
import UniqFM import UniqFM
import HscTypes ( handleFlagWarnings ) import HscTypes ( handleFlagWarnings, getSafeMode )
import HsImpExp import HsImpExp
import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
import RdrName (RdrName) import RdrName (RdrName)
...@@ -134,6 +134,7 @@ builtin_commands = [ ...@@ -134,6 +134,7 @@ builtin_commands = [
("help", keepGoing help, noCompletion), ("help", keepGoing help, noCompletion),
("history", keepGoing historyCmd, noCompletion), ("history", keepGoing historyCmd, noCompletion),
("info", keepGoing' info, completeIdentifier), ("info", keepGoing' info, completeIdentifier),
("issafe", keepGoing' isSafeCmd, completeModule),
("kind", keepGoing' kindOfType, completeIdentifier), ("kind", keepGoing' kindOfType, completeIdentifier),
("load", keepGoingPaths loadModule_, completeHomeModuleOrFile), ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
("list", keepGoing' listCmd, noCompletion), ("list", keepGoing' listCmd, noCompletion),
...@@ -211,6 +212,7 @@ helpText = ...@@ -211,6 +212,7 @@ helpText =
" :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
" :help, :? display this list of commands\n" ++ " :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\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" ++ " :kind <type> show the kind of <type>\n" ++
" :load [*]<module> ... load module(s) and their dependents\n" ++ " :load [*]<module> ... load module(s) and their dependents\n" ++
" :main [<arguments> ...] run the main function with the given arguments\n" ++ " :main [<arguments> ...] run the main function with the given arguments\n" ++
...@@ -1317,6 +1319,51 @@ runScript filename = do ...@@ -1317,6 +1319,51 @@ runScript filename = do
then scriptLoop script then scriptLoop script
else return () 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 -- 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