Commit 4ff7d0bb authored by dterei's avatar dterei

Refactor Safe Haskell check to provide hscCheckSafe GHC API

parent 565f97b2
......@@ -60,6 +60,7 @@ module HscMain
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscCheckSafe
#ifdef GHCI
, hscGetModuleInterface
, hscRnImportDecls
......@@ -886,9 +887,8 @@ hscFileFrontEnd mod_summary = do
-- inference mode.
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env = do
hsc_env <- getHscEnv
dflags <- getDynFlags
tcg_env' <- checkSafeImports dflags hsc_env tcg_env
tcg_env' <- checkSafeImports dflags tcg_env
case safeLanguageOn dflags of
True -> do
-- we nuke user written RULES in -XSafe
......@@ -925,8 +925,8 @@ hscCheckSafeImports tcg_env = do
-- dependencies for a module are collected and unioned.
-- Specifically see the Note [RnNames . Tracking Trust Transitively]
-- and the Note [RnNames . Trust Own Package].
checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags hsc_env tcg_env
checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkSafeImports dflags tcg_env
= do
-- We want to use the warning state specifically for detecting if safe
-- inference has failed, so store and clear any existing warnings.
......@@ -981,40 +981,48 @@ checkSafeImports dflags hsc_env tcg_env
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
= return v1
-- easier interface to work with
checkSafe (_, _, False) = return Nothing
checkSafe (m, l, True ) = hscCheckSafe' dflags m l
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
hsc_eps <- liftIO $ hscEPS hsc_env
let pkgIfaceT = eps_PIT hsc_eps
homePkgT = hsc_HPT hsc_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
return iface
isHomePkg :: Module -> Bool
isHomePkg m
| thisPackage dflags == modulePackageId m = True
| otherwise = False
-- | Check the package a module resides in is trusted.
-- Safe compiled modules are trusted without requiring
-- that their package is trusted. For trustworthy modules,
-- modules in the home package are trusted but otherwise
-- we check the package trust flag.
packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted _ _ _
| not (packageTrustOn dflags) = True
packageTrusted Sf_Safe False _ = True
packageTrusted Sf_SafeInfered False _ = True
packageTrusted _ _ m
| isHomePkg m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m)
-- Here we check the transitive package trust requirements are OK still.
checkPkgTrust :: [PackageId] -> Hsc ()
checkPkgTrust pkgs =
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
errors = catMaybes $ map go pkgs
go pkg
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg noSrcSpan
$ text "The package (" <> ppr pkg <> text ") is required"
<> text " to be trusted but it isn't!"
-- Is a module trusted? Return Nothing if True, or a String
-- if it isn't, containing the reason it isn't. Also return
-- if the module trustworthy (true) or safe (false) so we know
-- if we should check if the package itself is trusted in the
-- future.
-- | Check that a module is safe to import.
--
-- We return a package id if the safe import is OK and a Nothing otherwise
-- with the reason for the failure printed out.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO (Maybe PackageId)
hscCheckSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
hscCheckSafe' dflags m l
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId)
hscCheckSafe' dflags m l = do
tw <- isModSafe m l
case tw of
False -> return Nothing
True | isHomePkg m -> return Nothing
| otherwise -> return $ Just $ modulePackageId m
where
-- Is a module trusted? Return Nothing if True, or a String if it isn't,
-- containing the reason it isn't. Also return if the module trustworthy
-- (true) or safe (false) so we know if we should check if the package
-- itself is trusted in the future.
isModSafe :: Module -> SrcSpan -> Hsc (Bool)
isModSafe m l = do
iface <- lookup' m
......@@ -1047,30 +1055,34 @@ checkSafeImports dflags hsc_env tcg_env
<+> text "can't be safely imported!"
<+> text "The module itself isn't safe."
-- Here we check the transitive package trust requirements are OK still.
checkPkgTrust :: [PackageId] -> Hsc ()
checkPkgTrust pkgs =
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
errors = catMaybes $ map go pkgs
go pkg
| trusted $ getPackageDetails (pkgState dflags) pkg
= Nothing
| otherwise
= Just $ mkPlainErrMsg noSrcSpan
$ text "The package (" <> ppr pkg <> text ") is required"
<> text " to be trusted but it isn't!"
-- | Check the package a module resides in is trusted.
-- Safe compiled modules are trusted without requiring
-- that their package is trusted. For trustworthy modules,
-- modules in the home package are trusted but otherwise
-- we check the package trust flag.
packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted _ _ _
| not (packageTrustOn dflags) = True
packageTrusted Sf_Safe False _ = True
packageTrusted Sf_SafeInfered False _ = True
packageTrusted _ _ m
| isHomePkg m = True
| otherwise = trusted $ getPackageDetails (pkgState dflags)
(modulePackageId m)
checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
checkSafe (_, _, False) = return Nothing
checkSafe (m, l, True ) = do
tw <- isModSafe m l
return $ pkg tw
where pkg False = Nothing
pkg True | isHomePkg m = Nothing
| otherwise = Just (modulePackageId m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
hsc_env <- getHscEnv
hsc_eps <- liftIO $ hscEPS hsc_env
let pkgIfaceT = eps_PIT hsc_eps
homePkgT = hsc_HPT hsc_env
iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
return iface
isHomePkg :: Module -> Bool
isHomePkg m
| thisPackage dflags == modulePackageId m = True
| otherwise = False
-- | Set module to unsafe and wipe trust information.
--
......
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