Commit cb40a3fd authored by dterei's avatar dterei
Browse files

SafeHaskell: Add new package flags for setting trust

Now ghc supports:
  - trust => Set a package to be trusted
  - distrust => Set a package to be untrusted
  - distrust-all-package => Set all packages to be untrusted by default
parent 83dedf64
......@@ -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 }
......
......@@ -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
......
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