Commit 93e8ae26 authored by dterei's avatar dterei

Fix :issafe command (#7172).

parent 2b5b178f
......@@ -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.
......
......@@ -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
......
......@@ -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
......
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