Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/4ff7d0bb9d3e627843e601e6a0a623a6b03783a2 >--------------------------------------------------------------- commit 4ff7d0bb9d3e627843e601e6a0a623a6b03783a2 Author: David Terei <[email protected]> Date: Fri Dec 16 13:45:53 2011 -0800 Refactor Safe Haskell check to provide hscCheckSafe GHC API >--------------------------------------------------------------- compiler/main/HscMain.hs | 128 +++++++++++++++++++++++++--------------------- 1 files changed, 70 insertions(+), 58 deletions(-) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index f3df384..c705526 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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. @@ -982,39 +982,47 @@ checkSafeImports dflags hsc_env tcg_env | otherwise = return v1 - 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 + -- easier interface to work with + checkSafe (_, _, False) = return Nothing + checkSafe (m, l, True ) = hscCheckSafe' dflags m l - -- | 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. -- _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
