Commit ae676198 authored by David Feuer's avatar David Feuer Committed by Ben Gamari

Eliminate ListSetOps from imp_trust_pkgs

Eliminate ListSetOps from imp_trust_pkgs and imp_dep_pkgs

Replace Map with NameEnv in TmOracle

Reviewers: austin, dfeuer, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D3113
parent 27a1b12f
......@@ -17,7 +17,6 @@ import Outputable
import Util
import UniqSet
import UniqDFM
import ListSetOps
import Fingerprint
import Maybes
......@@ -25,6 +24,7 @@ import Data.List
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
-- | Extract information from the rename and typecheck phases to produce
-- a dependencies information for the module being compiled.
......@@ -46,14 +46,14 @@ mkDependencies
-- on M.hi-boot, and hence that we should do the hi-boot consistency
-- check.)
pkgs | th_used = insertList (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
pkgs | th_used = Set.insert (toInstalledUnitId thUnitId) (imp_dep_pkgs imports)
| otherwise = imp_dep_pkgs imports
-- Set the packages required to be Safe according to Safe Haskell.
-- See Note [RnNames . Tracking Trust Transitively]
sorted_pkgs = sort pkgs
sorted_pkgs = sort (Set.toList pkgs)
trust_pkgs = imp_trust_pkgs imports
dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs
dep_pkgs' = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs
return Deps { dep_mods = dep_mods,
dep_pkgs = dep_pkgs',
......
......@@ -32,7 +32,7 @@ import TcHsSyn
import MonadUtils
import Util
import qualified Data.Map as Map
import NameEnv
{-
%************************************************************************
......@@ -43,7 +43,7 @@ import qualified Data.Map as Map
-}
-- | The type of substitutions.
type PmVarEnv = Map.Map Name PmExpr
type PmVarEnv = NameEnv PmExpr
-- | The environment of the oracle contains
-- 1. A Bool (are there any constraints we cannot handle? (PmExprOther)).
......@@ -80,7 +80,7 @@ varIn x e = case e of
-- | Flatten the DAG (Could be improved in terms of performance.).
flattenPmVarEnv :: PmVarEnv -> PmVarEnv
flattenPmVarEnv env = Map.map (exprDeepLookup env) env
flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env
-- | The state of the term oracle (includes complex constraints that cannot
-- progress unless we get more information).
......@@ -88,7 +88,7 @@ type TmState = ([ComplexEq], TmOracleEnv)
-- | Initial state of the oracle.
initialTmState :: TmState
initialTmState = ([], (False, Map.empty))
initialTmState = ([], (False, emptyNameEnv))
-- | Solve a complex equality (top-level).
solveOneEq :: TmState -> ComplexEq -> Maybe TmState
......@@ -140,7 +140,7 @@ extendSubstAndSolve x e (standby, (unhandled, env))
-- had some progress. Careful about performance:
-- See Note [Representation of Term Equalities] in deSugar/Check.hs
(changed, unchanged) = partitionWith (substComplexEq x e) standby
new_incr_state = (unchanged, (unhandled, Map.insert x e env))
new_incr_state = (unchanged, (unhandled, extendNameEnv env x e))
-- | When we know that a variable is fresh, we do not actually have to
-- check whether anything changes, we know that nothing does. Hence,
......@@ -149,7 +149,7 @@ extendSubstAndSolve x e (standby, (unhandled, env))
extendSubst :: Id -> PmExpr -> TmState -> TmState
extendSubst y e (standby, (unhandled, env))
| isNotPmExprOther simpl_e
= (standby, (unhandled, Map.insert x simpl_e env))
= (standby, (unhandled, extendNameEnv env x simpl_e))
| otherwise = (standby, (True, env))
where
x = idName y
......@@ -219,7 +219,7 @@ applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)
-- | Apply an (un-flattened) substitution to a variable.
varDeepLookup :: PmVarEnv -> Name -> PmExpr
varDeepLookup env x
| Just e <- Map.lookup x env = exprDeepLookup env e -- go deeper
| Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper
| otherwise = PmExprVar x -- terminal
{-# INLINE varDeepLookup #-}
......
......@@ -333,6 +333,7 @@ import qualified Parser
import Lexer
import ApiAnnotation
import qualified GHC.LanguageExtensions as LangExt
import Data.Set (Set)
import System.Directory ( doesFileExist )
import Data.Maybe
......@@ -1412,7 +1413,7 @@ 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, [InstalledUnitId])
moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
......
......@@ -137,7 +137,6 @@ import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
import TcEnv
import Maybes
import DynFlags
import ErrUtils
......@@ -163,6 +162,8 @@ import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Map as Map
import qualified Data.Set as S
import Data.Set (Set)
#include "HsVersions.h"
......@@ -906,15 +907,15 @@ checkSafeImports dflags tcg_env
clearWarnings
-- Check safe imports are correct
safePkgs <- mapM checkSafe safeImps
safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
safeErrs <- getWarnings
clearWarnings
-- Check non-safe imports are correct if inferring safety
-- See the Note [Safe Haskell Inference]
(infErrs, infPkgs) <- case (safeInferOn dflags) of
False -> return (emptyBag, [])
True -> do infPkgs <- mapM checkSafe regImps
False -> return (emptyBag, S.empty)
True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
infErrs <- getWarnings
clearWarnings
return (infErrs, infPkgs)
......@@ -958,17 +959,19 @@ checkSafeImports dflags tcg_env
= return v1
-- easier interface to work with
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' dflags m l
-- what pkg's to add to our trust requirements
pkgTrustReqs :: Set InstalledUnitId -> Set InstalledUnitId -> Bool -> ImportAvails
pkgTrustReqs req inf infPassed | safeInferOn dflags
&& safeHaskell dflags == Sf_None && infPassed
= emptyImportAvails {
imp_trust_pkgs = catMaybes req ++ catMaybes inf
imp_trust_pkgs = req `S.union` inf
}
pkgTrustReqs _ _ _ | safeHaskell dflags == Sf_Unsafe
= emptyImportAvails
pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = catMaybes req }
pkgTrustReqs req _ _ = emptyImportAvails { imp_trust_pkgs = req }
-- | Check that a module is safe to import.
--
......@@ -983,13 +986,13 @@ hscCheckSafe hsc_env m l = runHsc hsc_env $ do
return $ isEmptyBag errs
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, [InstalledUnitId])
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
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
let pkgs' | Just p <- self = S.insert p pkgs
| otherwise = pkgs
return (good, pkgs')
......@@ -997,7 +1000,7 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do
-- 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 InstalledUnitId, [InstalledUnitId])
hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' dflags m l = do
(tw, pkgs) <- isModSafe m l
case tw of
......@@ -1007,7 +1010,7 @@ hscCheckSafe' dflags m l = do
-- Not necessary if that is reflected in dependencies
| otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
where
isModSafe :: Module -> SrcSpan -> Hsc (Bool, [InstalledUnitId])
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe m l = do
iface <- lookup' m
case iface of
......@@ -1025,7 +1028,7 @@ hscCheckSafe' dflags m l = do
-- check package is trusted
safeP = packageTrusted trust trust_own_pkg m
-- pkg trust reqs
pkgRs = map fst $ filter snd $ dep_pkgs $ mi_deps iface'
pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
-- General errors we throw but Safe errors we log
errs = case (safeM, safeP) of
(True, True ) -> emptyBag
......@@ -1083,20 +1086,20 @@ hscCheckSafe' dflags m l = do
| otherwise = False
-- | Check the list of packages are trusted.
checkPkgTrust :: DynFlags -> [InstalledUnitId] -> Hsc ()
checkPkgTrust :: DynFlags -> Set InstalledUnitId -> Hsc ()
checkPkgTrust dflags pkgs =
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
where
errors = catMaybes $ map go pkgs
go pkg
errors = S.foldr go [] pkgs
go pkg acc
| trusted $ getInstalledPackageDetails dflags pkg
= Nothing
= acc
| otherwise
= Just $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
-- | Set module to unsafe and (potentially) wipe trust information.
--
......@@ -1125,7 +1128,7 @@ markUnsafeInfer tcg_env whyUnsafe = do
False -> return tcg_env
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = [] }
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
pprMod = ppr $ moduleName $ tcg_mod tcg_env
whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
, text "Reason:"
......
......@@ -55,8 +55,10 @@ import Data.Map ( Map )
import qualified Data.Map as Map
import Data.Ord ( comparing )
import Data.List ( partition, (\\), find, sortBy )
import qualified Data.Set as S
-- import qualified Data.Set as Set
import System.FilePath ((</>))
import System.IO
{-
......@@ -397,15 +399,15 @@ calculateAvails dflags iface mod_safe' want_boot =
imp_orphs = orphans,
imp_finsts = finsts,
imp_dep_mods = mkModDeps dependent_mods,
imp_dep_pkgs = map fst $ dependent_pkgs,
imp_dep_pkgs = S.fromList . map fst $ dependent_pkgs,
-- Add in the imported modules trusted package
-- requirements. ONLY do this though if we import the
-- module as a safe import.
-- See Note [Tracking Trust Transitively]
-- and Note [Trust Transitive Property]
imp_trust_pkgs = if mod_safe'
then map fst $ filter snd dependent_pkgs
else [],
then S.fromList . map fst $ filter snd dependent_pkgs
else S.empty,
-- Do we require our own pkg to be trusted?
-- See Note [Trust Own Package]
imp_trust_own_pkg = pkg_trust_req
......
......@@ -124,8 +124,9 @@ import Util
import Bag
import Inst (tcGetInsts)
import qualified GHC.LanguageExtensions as LangExt
import HsDumpAst
import Data.Data ( Data )
import HsDumpAst
import qualified Data.Set as S
import Control.Monad
......@@ -2489,7 +2490,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
, text "Dependent modules:" <+>
pprUDFM (imp_dep_mods imports) ppr
, text "Dependent packages:" <+>
ppr (sortBy compare $ imp_dep_pkgs imports)]
ppr (S.toList $ imp_dep_pkgs imports)]
where -- The use of sortBy is just to reduce unnecessary
-- wobbling in testsuite output
......
......@@ -181,6 +181,7 @@ import Control.Monad (ap, liftM, msum)
import qualified Control.Monad.Fail as MonadFail
#endif
import Data.Set ( Set )
import qualified Data.Set as S
import Data.Map ( Map )
import Data.Dynamic ( Dynamic )
......@@ -1229,12 +1230,12 @@ data ImportAvails
-- compiling M might not need to consult X.hi, but X
-- is still listed in M's dependencies.
imp_dep_pkgs :: [InstalledUnitId],
imp_dep_pkgs :: Set InstalledUnitId,
-- ^ Packages needed by the module being compiled, whether directly,
-- or via other modules in this package, or via modules imported
-- from other packages.
imp_trust_pkgs :: [InstalledUnitId],
imp_trust_pkgs :: Set InstalledUnitId,
-- ^ This is strictly a subset of imp_dep_pkgs and records the
-- packages the current module needs to trust for Safe Haskell
-- compilation to succeed. A package is required to be trusted if
......@@ -1269,8 +1270,8 @@ mkModDeps deps = foldl add emptyUDFM deps
emptyImportAvails :: ImportAvails
emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUDFM,
imp_dep_pkgs = [],
imp_trust_pkgs = [],
imp_dep_pkgs = S.empty,
imp_trust_pkgs = S.empty,
imp_trust_own_pkg = False,
imp_orphs = [],
imp_finsts = [] }
......@@ -1292,8 +1293,8 @@ plusImportAvails
imp_orphs = orphs2, imp_finsts = finsts2 })
= ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2,
imp_dep_mods = plusUDFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2,
imp_dep_pkgs = dpkgs1 `S.union` dpkgs2,
imp_trust_pkgs = tpkgs1 `S.union` tpkgs2,
imp_trust_own_pkg = tself1 || tself2,
imp_orphs = orphs1 `unionLists` orphs2,
imp_finsts = finsts1 `unionLists` finsts2 }
......
......@@ -8,7 +8,7 @@
{-# LANGUAGE CPP #-}
module ListSetOps (
unionLists, minusList, insertList,
unionLists, minusList,
-- Association lists
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
......@@ -41,10 +41,6 @@ getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
************************************************************************
-}
insertList :: Eq a => a -> [a] -> [a]
-- Assumes the arg list contains no dups; guarantees the result has no dups
insertList x xs | isIn "insert" x xs = xs
| otherwise = x : xs
unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
-- Assumes that the arguments contain no duplicates
......
......@@ -96,6 +96,7 @@ import Data.Function
import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )
import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
partition, sort, sortBy )
import qualified Data.Set as S
import Data.Maybe
import qualified Data.Map as M
import Data.Time.LocalTime ( getZonedTime )
......@@ -2042,15 +2043,15 @@ isSafeModule m = do
-- 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 (not $ null good)
when (not $ S.null good)
(liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++
(intercalate ", " $ map (showPpr dflags) good))
case msafe && null bad of
(intercalate ", " $ map (showPpr dflags) (S.toList good)))
case msafe && S.null bad of
True -> liftIO $ putStrLn $ mname ++ " is trusted!"
False -> do
when (not $ null bad)
(liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "
++ (intercalate ", " $ map (showPpr dflags) bad))
++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))
liftIO $ putStrLn $ mname ++ " is NOT trusted!"
where
......@@ -2060,8 +2061,8 @@ isSafeModule m = do
| thisPackage dflags == moduleUnitId md = True
| otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)
tallyPkgs dflags deps | not (packageTrustOn dflags) = ([], [])
| otherwise = partition part deps
tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)
| otherwise = S.partition part deps
where part pkg = trusted $ getInstalledPackageDetails dflags 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