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 ...@@ -287,6 +287,7 @@ data DynFlag
| Opt_SplitObjs | Opt_SplitObjs
| Opt_StgStats | Opt_StgStats
| Opt_HideAllPackages | Opt_HideAllPackages
| Opt_DistrustAllPackages
| Opt_PrintBindResult | Opt_PrintBindResult
| Opt_Haddock | Opt_Haddock
| Opt_HaddockOptions | Opt_HaddockOptions
...@@ -734,10 +735,12 @@ doingTickyProfiling _ = opt_Ticky ...@@ -734,10 +735,12 @@ doingTickyProfiling _ = opt_Ticky
-- static. If the way flags were made dynamic, we could fix this. -- static. If the way flags were made dynamic, we could fix this.
data PackageFlag data PackageFlag
= ExposePackage String = ExposePackage String
| ExposePackageId String | ExposePackageId String
| HidePackage String | HidePackage String
| IgnorePackage String | IgnorePackage String
| TrustPackage String
| DistrustPackage String
deriving Eq deriving Eq
defaultHscTarget :: HscTarget defaultHscTarget :: HscTarget
...@@ -1666,16 +1669,19 @@ dynamic_flags = [ ...@@ -1666,16 +1669,19 @@ dynamic_flags = [
package_flags :: [Flag (CmdLineP DynFlags)] package_flags :: [Flag (CmdLineP DynFlags)]
package_flags = [ package_flags = [
------- Packages ---------------------------------------------------- ------- Packages ----------------------------------------------------
flagC "package-conf" (HasArg extraPkgConf_) flagC "package-conf" (HasArg extraPkgConf_)
, flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf))
, flagC "package-name" (hasArg setPackageName) , flagC "package-name" (hasArg setPackageName)
, flagC "package-id" (HasArg exposePackageId) , flagC "package-id" (HasArg exposePackageId)
, flagC "package" (HasArg exposePackage) , flagC "package" (HasArg exposePackage)
, flagC "hide-package" (HasArg hidePackage) , flagC "hide-package" (HasArg hidePackage)
, flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages))
, flagC "ignore-package" (HasArg ignorePackage) , flagC "ignore-package" (HasArg ignorePackage)
, flagC "syslib" (HasArg (\s -> do { exposePackage s , flagC "syslib" (HasArg (\s -> do { exposePackage s
; deprecate "Use -package instead" })) ; 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 type TurnOnFlag = Bool -- True <=> we are turning the flag on
...@@ -2279,7 +2285,8 @@ addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes ...@@ -2279,7 +2285,8 @@ addCmdlineHCInclude a = upd (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes
extraPkgConf_ :: FilePath -> DynP () extraPkgConf_ :: FilePath -> DynP ()
extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) 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 = exposePackage p =
upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s })
exposePackageId p = exposePackageId p =
...@@ -2288,6 +2295,10 @@ hidePackage p = ...@@ -2288,6 +2295,10 @@ hidePackage p =
upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
ignorePackage p = ignorePackage p =
upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) 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 :: String -> DynFlags -> DynFlags
setPackageName p s = s{ thisPackage = stringToPackageId p } setPackageName p s = s{ thisPackage = stringToPackageId p }
......
...@@ -171,7 +171,7 @@ initPackages :: DynFlags -> IO (DynFlags, [PackageId]) ...@@ -171,7 +171,7 @@ initPackages :: DynFlags -> IO (DynFlags, [PackageId])
initPackages dflags = do initPackages dflags = do
pkg_db <- case pkgDatabase dflags of pkg_db <- case pkgDatabase dflags of
Nothing -> readPackageConfigs dflags Nothing -> readPackageConfigs dflags
Just db -> return $ maybeHidePackages dflags db Just db -> return $ setBatchPackageFlags dflags db
(pkg_state, preload, this_pkg) (pkg_state, preload, this_pkg)
<- mkPackageState dflags pkg_db [] (thisPackage dflags) <- mkPackageState dflags pkg_db [] (thisPackage dflags)
return (dflags{ pkgDatabase = Just pkg_db, return (dflags{ pkgDatabase = Just pkg_db,
...@@ -249,16 +249,23 @@ readPackageConfig dflags conf_file = do ...@@ -249,16 +249,23 @@ readPackageConfig dflags conf_file = do
top_dir = topDir dflags top_dir = topDir dflags
pkgroot = takeDirectory conf_file pkgroot = takeDirectory conf_file
pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs 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 return pkg_configs2
maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig] setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
maybeHidePackages dflags pkgs setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs
| dopt Opt_HideAllPackages dflags = map hide pkgs
| otherwise = pkgs
where 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 } hide pkg = pkg{ exposed = False }
distrust pkg = pkg{ exposed = False }
-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
...@@ -344,6 +351,20 @@ applyPackageFlag unusable pkgs flag = ...@@ -344,6 +351,20 @@ applyPackageFlag unusable pkgs flag =
Right (ps,qs) -> return (map hide ps ++ qs) Right (ps,qs) -> return (map hide ps ++ qs)
where hide p = p {exposed=False} 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" _ -> panic "applyPackageFlag"
where where
...@@ -407,6 +428,8 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err)) ...@@ -407,6 +428,8 @@ packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
HidePackage p -> text "-hide-package " <> text p HidePackage p -> text "-hide-package " <> text p
ExposePackage p -> text "-package " <> text p ExposePackage p -> text "-package " <> text p
ExposePackageId p -> text "-package-id " <> 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_reasons = vcat (map ppr_reason reasons)
ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason 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