From 8a5120824bed84682c2a8dc855c9c1d1f1ff19ee Mon Sep 17 00:00:00 2001
From: David Terei <davidterei@gmail.com>
Date: Thu, 23 Aug 2012 01:59:05 -0700
Subject: [PATCH] Fix :issafe command (#7172).
MERGED from commit 93e8ae26e42fbe9e600db125182d7823a78e2925
---
compiler/main/GHC.hs | 6 +++++
compiler/main/HscMain.hs | 22 ++++++++++++++----
ghc/InteractiveUI.hs | 48 ++++++++++++++--------------------------
3 files changed, 41 insertions(+), 35 deletions(-)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index bedb30002a34..b1cc7868400b 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -91,6 +91,7 @@ module GHC (
findModule, lookupModule,
#ifdef GHCI
isModuleTrusted,
+ moduleTrustReqs,
setContext, getContext,
getNamesInScope,
getRdrNamesInScope,
@@ -1335,6 +1336,11 @@ isModuleTrusted :: GhcMonad m => Module -> m Bool
isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
+-- | Return if a module is trusted and the pkgs it depends on to be trusted.
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, [PackageId])
+moduleTrustReqs m = withSession $ \hsc_env ->
+ liftIO $ hscGetSafe hsc_env m noSrcSpan
+
-- | EXPERIMENTAL: DO NOT USE.
--
-- Set the monad GHCi lifts user statements into.
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 2552b77f2903..010bc1209c8b 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -61,6 +61,7 @@ module HscMain
, hscTcRcLookupName
, hscTcRnGetInfo
, hscCheckSafe
+ , hscGetSafe
#ifdef GHCI
, hscIsGHCiMonad
, hscGetModuleInterface
@@ -1023,6 +1024,21 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
errs <- getWarnings
return $ isEmptyBag errs
+-- | Return if a module is trusted and the pkgs it depends on to be trusted.
+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [PackageId])
+hscGetSafe hsc_env m l = runHsc hsc_env $ do
+ dflags <- getDynFlags
+ (self, pkgs) <- hscCheckSafe' dflags m l
+ good <- isEmptyBag `fmap` getWarnings
+ clearWarnings -- don't want them printed...
+ let pkgs' | Just p <- self = p:pkgs
+ | otherwise = pkgs
+ return (good, pkgs')
+
+-- | Is a module trusted? If not, throw or log errors depending on the type.
+-- Return (regardless of trusted or not) if the trust type requires the modules
+-- own package be trusted and a list of other packages required to be trusted
+-- (these later ones haven't been checked) but the own package trust has been.
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId, [PackageId])
hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l
@@ -1031,10 +1047,6 @@ hscCheckSafe' dflags m l = do
True | isHomePkg m -> return (Nothing, pkgs)
| otherwise -> return (Just $ modulePackageId m, pkgs)
where
- -- Is a module trusted? If not, throw or log errors depending on the type.
- -- Return (regardless of trusted or not) if the trust type requires the
- -- modules own package be trusted and a list of other packages required to
- -- be trusted (these later ones haven't been checked)
isModSafe :: Module -> SrcSpan -> Hsc (Bool, [PackageId])
isModSafe m l = do
iface <- lookup' m
@@ -1080,6 +1092,8 @@ hscCheckSafe' dflags m l = do
-- trustworthy modules, modules in the home package are trusted but
-- otherwise we check the package trust flag.
packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
+ packageTrusted Sf_None _ _ = False -- shouldn't hit these cases
+ packageTrusted Sf_Unsafe _ _ = False -- prefer for completeness.
packageTrusted _ _ _
| not (packageTrustOn dflags) = True
packageTrusted Sf_Safe False _ = True
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 0bd0592727e2..e98484122f5e 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -33,7 +33,7 @@ import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
handleSourceError )
import HsImpExp
-import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs, hsc_IC,
+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
setInteractivePrintName )
import Module
import Name
@@ -1487,48 +1487,34 @@ isSafeModule m = do
(ghcError $ CmdLineError $ "can't load interface file for module: " ++
(GHC.moduleNameString $ GHC.moduleName m))
- let iface' = fromJust iface
-
- trust = showPpr dflags $ getSafeMode $ GHC.mi_trust iface'
- pkgT = packageTrusted dflags m
- pkg = if pkgT then "trusted" else "untrusted"
- (good', bad') = tallyPkgs dflags $
- map fst $ filter snd $ dep_pkgs $ GHC.mi_deps iface'
- (good, bad) = case GHC.mi_trust_pkg iface' of
- True | pkgT -> (modulePackageId m:good', bad')
- True -> (good', modulePackageId m:bad')
- False -> (good', bad')
+ (msafe, pkgs) <- GHC.moduleTrustReqs m
+ let trust = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface
+ pkg = if packageTrusted dflags m then "trusted" else "untrusted"
+ (good, bad) = tallyPkgs dflags pkgs
+ -- print info to user...
liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"
- liftIO $ putStrLn $ "Package Trust: "
- ++ (if packageTrustOn dflags then "On" else "Off")
-
- when (packageTrustOn dflags && not (null good))
+ liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")
+ when (not $ null good)
(liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
(intercalate ", " $ map packageIdString good))
-
- case goodTrust (getSafeMode $ GHC.mi_trust iface') of
- True | (null bad || not (packageTrustOn dflags)) ->
- liftIO $ putStrLn $ mname ++ " is trusted!"
-
- True -> do
- liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
- ++ (intercalate ", " $ map packageIdString bad)
+ case msafe && null bad of
+ True -> liftIO $ putStrLn $ mname ++ " is trusted!"
+ False -> do
+ when (not $ null bad)
+ (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
+ ++ (intercalate ", " $ map packageIdString bad))
liftIO $ putStrLn $ mname ++ " is NOT trusted!"
- False -> liftIO $ putStrLn $ mname ++ " is NOT trusted!"
-
where
- goodTrust t = t `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
-
mname = GHC.moduleNameString $ GHC.moduleName m
packageTrusted dflags md
| thisPackage dflags == modulePackageId md = True
- | otherwise = trusted $ getPackageDetails (pkgState dflags)
- (modulePackageId md)
+ | otherwise = trusted $ getPackageDetails (pkgState dflags) (modulePackageId md)
- tallyPkgs dflags deps = partition part deps
+ tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
+ | otherwise = partition part deps
where state = pkgState dflags
part pkg = trusted $ getPackageDetails state pkg
--
GitLab