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

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