diff options
| -rw-r--r-- | compiler/main/DynFlags.hs | 39 | ||||
| -rw-r--r-- | compiler/main/Packages.lhs | 35 |
2 files changed, 54 insertions, 20 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 35859158db..c125949f05 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -287,6 +287,7 @@ data DynFlag | Opt_SplitObjs | Opt_StgStats | Opt_HideAllPackages + | Opt_DistrustAllPackages | Opt_PrintBindResult | Opt_Haddock | Opt_HaddockOptions @@ -734,10 +735,12 @@ doingTickyProfiling _ = opt_Ticky -- static. If the way flags were made dynamic, we could fix this. data PackageFlag - = ExposePackage String + = ExposePackage String | ExposePackageId String - | HidePackage String - | IgnorePackage String + | HidePackage String + | IgnorePackage String + | TrustPackage String + | DistrustPackage String deriving Eq defaultHscTarget :: HscTarget @@ -1666,16 +1669,19 @@ dynamic_flags = [ package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - flagC "package-conf" (HasArg extraPkgConf_) - , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - , flagC "package-name" (hasArg setPackageName) - , flagC "package-id" (HasArg exposePackageId) - , flagC "package" (HasArg exposePackage) - , flagC "hide-package" (HasArg hidePackage) - , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) - , flagC "ignore-package" (HasArg ignorePackage) - , flagC "syslib" (HasArg (\s -> do { exposePackage s - ; deprecate "Use -package instead" })) + flagC "package-conf" (HasArg extraPkgConf_) + , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , flagC "package-name" (hasArg setPackageName) + , flagC "package-id" (HasArg exposePackageId) + , flagC "package" (HasArg exposePackage) + , flagC "hide-package" (HasArg hidePackage) + , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + , flagC "ignore-package" (HasArg ignorePackage) + , flagC "syslib" (HasArg (\s -> do { exposePackage s + ; deprecate "Use -package instead" })) + , flagC "trust" (HasArg trustPackage) + , flagC "distrust" (HasArg distrustPackage) + , flagC "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on @@ -2279,7 +2285,8 @@ addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes extraPkgConf_ :: FilePath -> DynP () extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) -exposePackage, exposePackageId, hidePackage, ignorePackage :: String -> DynP () +exposePackage, exposePackageId, hidePackage, ignorePackage, + trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) exposePackageId p = @@ -2288,6 +2295,10 @@ hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ packageFlags = TrustPackage p : packageFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s }) setPackageName :: String -> DynFlags -> DynFlags setPackageName p s = s{ thisPackage = stringToPackageId p } diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 12316713d6..33858be1ff 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -171,7 +171,7 @@ initPackages :: DynFlags -> IO (DynFlags, [PackageId]) initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags - Just db -> return $ maybeHidePackages dflags db + Just db -> return $ setBatchPackageFlags dflags db (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, @@ -249,16 +249,23 @@ readPackageConfig dflags conf_file = do top_dir = topDir dflags pkgroot = takeDirectory conf_file pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs - pkg_configs2 = maybeHidePackages dflags pkg_configs1 + pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 -- return pkg_configs2 -maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig] -maybeHidePackages dflags pkgs - | dopt Opt_HideAllPackages dflags = map hide pkgs - | otherwise = pkgs +setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] +setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs where + maybeHideAll pkgs' + | dopt Opt_HideAllPackages dflags = map hide pkgs' + | otherwise = pkgs' + + maybeDistrustAll pkgs' + | dopt Opt_DistrustAllPackages dflags = map distrust pkgs' + | otherwise = pkgs' + hide pkg = pkg{ exposed = False } + distrust pkg = pkg{ exposed = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig @@ -344,6 +351,20 @@ applyPackageFlag unusable pkgs flag = Right (ps,qs) -> return (map hide ps ++ qs) where hide p = p {exposed=False} + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr flag ps + Right (ps,qs) -> return (map distrust ps ++ qs) + where distrust p = p {trusted=False} + _ -> panic "applyPackageFlag" where @@ -407,6 +428,8 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) HidePackage p -> text "-hide-package " <> text p ExposePackage p -> text "-package " <> text p ExposePackageId p -> text "-package-id " <> text p + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason |