Refactor package flags into several distinct types.

Summary:
Previously, all package flags (-package, -trust-package,
-ignore-package) were bundled up into a single packageFlags
field in DynFlags, under a single type.  This commit separates
them based on what they do.

This is a nice improvement, because it means that Packages can
then be refactored so that a number of functions are "tighter":

    - We know longer have to partition PackageFlags into
      the ignore flag and other flags; ignore flags are just
      put into their own field.

    - Trust flags modify the package database, but exposed
      flags do not (they modify the visibility map); now
      applyPackageFlag and applyTrustFlag have tighter signatures
      which reflect this.

This patch was motivated by the need to have a separate visibility
map for plugin packages, which will be in a companion patch.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: austin, bgamari, duncan

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1659

2 files changed, 136 insertions, 86 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 556175c0ea..5844bc0dc2 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -45,6 +45,7 @@ module DynFlags (
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,
         PackageFlag(..), PackageArg(..), ModRenaming(..),
+        IgnorePackageFlag(..), TrustFlag(..),
         PkgConfRef(..),
         Option(..), showOpt,
         DynLibLoader(..),
@@ -691,8 +692,12 @@ data DynFlags = DynFlags {
         -- ^ The @-package-db@ flags given on the command line, in the order
         -- they appeared.
 
+  ignorePackageFlags    :: [IgnorePackageFlag],
+        -- ^ The @-ignore-package@ flags from the command line
   packageFlags          :: [PackageFlag],
         -- ^ The @-package@ and @-hide-package@ flags from the command-line
+  trustFlags            :: [TrustFlag],
+        -- ^ The @-trust@ and @-distrust@ flags
   packageEnv            :: Maybe FilePath,
         -- ^ Filepath to the package environment file (if overriding default)
 
@@ -1088,13 +1093,16 @@ data ModRenaming = ModRenaming {
   } deriving (Eq)
 
 -- | Flags for manipulating packages.
+newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@
+
+data TrustFlag
+  = TrustPackage    String -- ^ @-trust@
+  | DistrustPackage String -- ^ @-distrust@
+
 data PackageFlag
   = ExposePackage   PackageArg ModRenaming -- ^ @-package@, @-package-id@
                                            -- and @-package-key@
   | HidePackage     String -- ^ @-hide-package@
-  | IgnorePackage   String -- ^ @-ignore-package@
-  | TrustPackage    String -- ^ @-trust-package@
-  | DistrustPackage String -- ^ @-distrust-package@
   deriving (Eq)
 
 defaultHscTarget :: Platform -> HscTarget
@@ -1424,6 +1432,8 @@ defaultDynFlags mySettings =
 
         extraPkgConfs           = id,
         packageFlags            = [],
+        ignorePackageFlags      = [],
+        trustFlags              = [],
         packageEnv              = Nothing,
         pkgDatabase             = Nothing,
         -- This gets filled in with GHC.setSessionDynFlags
@@ -3778,11 +3788,12 @@ exposeUnitId p =
 hidePackage p =
   upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
 ignorePackage p =
-  upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s })
+  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })
+
 trustPackage p = exposePackage p >> -- both trust and distrust also expose a package
-  upd (\s -> s{ packageFlags = TrustPackage p : packageFlags s })
+  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })
 distrustPackage p = exposePackage p >>
-  upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s })
+  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })
 
 exposePackage' :: String -> DynFlags -> DynFlags
 exposePackage' p dflags
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index a26b275bb3..f9a63aa3a7 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -503,27 +503,45 @@ mungePackagePaths top_dir pkgroot pkg =
 
 
 -- -----------------------------------------------------------------------------
--- Modify our copy of the package database based on a package flag
--- (-package, -hide-package, -ignore-package).
+-- Modify our copy of the package database based on trust flags,
+-- -trust and -distrust.
+
+applyTrustFlag
+   :: DynFlags
+   -> UnusablePackages
+   -> [PackageConfig]
+   -> TrustFlag
+   -> IO [PackageConfig]
+applyTrustFlag dflags unusable pkgs flag =
+  case flag of
+    -- 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       -> trustFlagErr dflags 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       -> trustFlagErr dflags flag ps
+         Right (ps,qs) -> return (map distrust ps ++ qs)
+          where distrust p = p {trusted=False}
 
 applyPackageFlag
    :: DynFlags
    -> UnusablePackages
-   -> ([PackageConfig], VisibilityMap)           -- Initial database
+   -> [PackageConfig]
+   -> VisibilityMap           -- Initially exposed
    -> PackageFlag               -- flag to apply
-   -> IO ([PackageConfig], VisibilityMap)        -- new database
-
--- ToDo: Unfortunately, we still have to plumb the package config through,
--- because Safe Haskell trust is still implemented by modifying the database.
--- Eventually, track that separately and then axe @[PackageConfig]@ from
--- this fold entirely
+   -> IO VisibilityMap        -- Now exposed
 
-applyPackageFlag dflags unusable (pkgs, vm) flag =
+applyPackageFlag dflags unusable pkgs vm flag =
   case flag of
     ExposePackage arg (ModRenaming b rns) ->
        case selectPackages (matching arg) pkgs unusable of
          Left ps         -> packageFlagErr dflags flag ps
-         Right (p:_,_) -> return (pkgs, vm')
+         Right (p:_,_) -> return vm'
           where
            n = fsPackageName p
            vm' = addToUFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
@@ -540,25 +558,9 @@ applyPackageFlag dflags unusable (pkgs, vm) flag =
     HidePackage str ->
        case selectPackages (matchingStr str) pkgs unusable of
          Left ps       -> packageFlagErr dflags flag ps
-         Right (ps,_) -> return (pkgs, vm')
+         Right (ps,_) -> return vm'
           where vm' = delListFromUFM vm (map packageConfigId ps)
 
-    -- 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 dflags flag ps
-         Right (ps,qs) -> return (map trust ps ++ qs, vm)
-          where trust p = p {trusted=True}
-
-    DistrustPackage str ->
-       case selectPackages (matchingStr str) pkgs unusable of
-         Left ps       -> packageFlagErr dflags flag ps
-         Right (ps,qs) -> return (map distrust ps ++ qs, vm)
-          where distrust p = p {trusted=False}
-
-    IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
-
 selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
                -> UnusablePackages
                -> Either [(PackageConfig, UnusablePackageReason)]
@@ -606,10 +608,23 @@ packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
   where dph_err = text "the " <> text pkg <> text " package is not installed."
                   $$ text "To install it: \"cabal install dph\"."
         is_dph_package pkg = "dph" `isPrefixOf` pkg
-
 packageFlagErr dflags flag reasons
+  = packageFlagErr' dflags (pprFlag flag) reasons
+
+trustFlagErr :: DynFlags
+             -> TrustFlag
+             -> [(PackageConfig, UnusablePackageReason)]
+             -> IO a
+trustFlagErr dflags flag reasons
+  = packageFlagErr' dflags (pprTrustFlag flag) reasons
+
+packageFlagErr' :: DynFlags
+               -> SDoc
+               -> [(PackageConfig, UnusablePackageReason)]
+               -> IO a
+packageFlagErr' dflags flag_doc reasons
   = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
-  where err = text "cannot satisfy " <> pprFlag flag <>
+  where err = text "cannot satisfy " <> flag_doc <>
                 (if null reasons then Outputable.empty else text ": ") $$
               nest 4 (ppr_reasons $$
                       text "(use -v for more information)")
@@ -619,11 +634,8 @@ packageFlagErr dflags flag reasons
 
 pprFlag :: PackageFlag -> SDoc
 pprFlag flag = case flag of
-    IgnorePackage p -> text "-ignore-package " <> text p
     HidePackage p   -> text "-hide-package " <> text p
     ExposePackage a rns -> ppr_arg a <> ppr_rns rns
-    TrustPackage p    -> text "-trust " <> text p
-    DistrustPackage p -> text "-distrust " <> text p
   where ppr_arg arg = case arg of
                      PackageArg    p -> text "-package " <> text p
                      PackageIdArg  p -> text "-package-id " <> text p
@@ -635,6 +647,11 @@ pprFlag flag = case flag of
         ppr_rn (orig, new) | orig == new = ppr orig
                            | otherwise = ppr orig <+> text "as" <+> ppr new
 
+pprTrustFlag :: TrustFlag -> SDoc
+pprTrustFlag flag = case flag of
+    TrustPackage p    -> text "-trust " <> text p
+    DistrustPackage p -> text "-distrust " <> text p
+
 -- -----------------------------------------------------------------------------
 -- Wired-in packages
 
@@ -647,7 +664,9 @@ findWiredInPackages
    :: DynFlags
    -> [PackageConfig]           -- database
    -> VisibilityMap             -- info on what packages are visible
-   -> IO ([PackageConfig], VisibilityMap, WiredPackagesMap)
+                                -- for wired in selection
+   -> IO ([PackageConfig],  -- package database updated for wired in
+          WiredPackagesMap) -- map from unit id to wired identity
 
 findWiredInPackages dflags pkgs vis_map = do
   --
@@ -746,14 +765,15 @@ findWiredInPackages dflags pkgs vis_map = do
                     | Just key' <- Map.lookup key wiredInMap = key'
                     | otherwise = key
 
-        updateVisibilityMap vis_map = foldl' f vis_map wired_in_pkgs
-          where f vm p = case lookupUFM vis_map (packageConfigId p) of
-                            Nothing -> vm
-                            Just r -> addToUFM vm (stringToUnitId
-                                                    (packageNameString p)) r
 
+  return (updateWiredInDependencies pkgs, wiredInMap)
+
+updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
+updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
+  where f vm (from, to) = case lookupUFM vis_map from of
+                    Nothing -> vm
+                    Just r -> addToUFM vm to r
 
-  return (updateWiredInDependencies pkgs, updateVisibilityMap vis_map, wiredInMap)
 
 -- ----------------------------------------------------------------------------
 
@@ -820,7 +840,7 @@ findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs
 -- -----------------------------------------------------------------------------
 -- Ignore packages
 
-ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
+ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
 ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
   where
   doit (IgnorePackage str) =
@@ -830,7 +850,6 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
         -- missing package is not an error for -ignore-package,
         -- because a common usage is to -ignore-package P as
         -- a preventative measure just in case P exists.
-  doit _ = panic "ignorePackages"
 
 -- -----------------------------------------------------------------------------
 -- When all the command-line options are in, we can process our package
@@ -854,41 +873,57 @@ mkPackageState dflags0 dbs preload0 = do
 {-
    Plan.
 
-   The goal is to build a single, unified package database based
-   on all of the input databases, which upholds the invariant that
-   there is only one package per any UnitId, and that there are no
-   dangling dependencies.  We'll do this by successively merging
-   each input database into this unified database:
+   There are two main steps for making the package state:
+
+    1. We want to build a single, unified package database based
+       on all of the input databases, which upholds the invariant that
+       there is only one package per any UnitId, and that there are no
+       dangling dependencies. We'll do this by successively merging each
+       input database into this unified database:
+
+       a) if an input database defines unit ID that is already in
+          the unified database, that package SHADOWS the existing
+          package in the current unified database
+            * for every such shadowed package, we remove it and any
+              packages which transitively depend on it from the
+              unified datbase
 
-   1. if an input database defines unit ID that is already in
-      the unified database, that package SHADOWS the existing
-      package in the unit database
-        * for every such shadowed package, we remove it and any
-          packages which transitively depend on it from the
-          unified datbase
+       b) remove packages selected by -ignore-package from input database
 
-   2. remove packages selected by -ignore-package from input database
+       c) remove any packages with missing dependencies or mutually recursive
+          dependencies from the input database
 
-   3. remove any packages with missing dependencies or mutually recursive
-      dependencies from the input database
+       d) report (with -v) any packages that were removed by steps 1-3
 
-   4. report (with -v) any packages that were removed by steps 1-3
+       e) merge the input database into the unified database
 
-   5. merge the input database into the unified database
+    2. We want to look at the flags controlling package visibility,
+       and build a mapping of what module names are in scope and
+       where they live.
 
-   Once this is all done, on the final unified database we:
+       a) on the final, unified database, we apply -trust/-distrust
+          flags directly, modifying the database so that the 'trusted'
+          field has the correct value.
 
-   1. apply flags to set exposed/hidden on the resulting packages
-      - if any flag refers to a package which was removed by 1-5, then
-        we can give an error message explaining why
+       b) we use the -package/-hide-package flags to compute a
+          visibility map, stating what packages are "exposed" for
+          the purposes of computing the module map.
+          * if any flag refers to a package which was removed by 1-5, then
+            we can give an error message explaining why
+          * if -hide-all-packages what not specified, this step also
+            hides packages which are superseded by later exposed packages
+          * this step is done TWICE if -plugin-package/-hide-all-plugin-packages
+            are used
 
-   2. hide any packages which are superseded by later exposed packages
+       c) based on the visibility map, we pick wired packages and rewrite
+          them to have the expected unitId.
+
+       d) finally, using the visibility map and the package database,
+          we build a mapping saying what every in scope module name points to.
 -}
 
-  let flags = reverse (packageFlags dflags)
-      (ignore_flags, other_flags) = partition is_ignore flags
-      is_ignore IgnorePackage{} = True
-      is_ignore _ = False
+  let other_flags = reverse (packageFlags dflags)
+      ignore_flags = reverse (ignorePackageFlags dflags)
 
   let merge (pkg_map, prev_unusable) (db_path, db) = do
             debugTraceMsg dflags 2 $
@@ -951,7 +986,10 @@ mkPackageState dflags0 dbs preload0 = do
               pkg_map' = mk_pkg_map (shadowed_pkgs ++ db3)
 
   (pkg_map1, unusable) <- foldM merge (Map.empty, Map.empty) dbs
-  let pkgs1 = Map.elems pkg_map1
+  -- Apply trust flags (these flags apply regardless of whether
+  -- or not packages are visible or not)
+  pkgs1 <- foldM (applyTrustFlag dflags unusable)
+                 (Map.elems pkg_map1) (reverse (trustFlags dflags))
 
   --
   -- Calculate the initial set of packages, prior to any package flags.
@@ -974,21 +1012,22 @@ mkPackageState dflags0 dbs preload0 = do
                          emptyUFM initial
 
   --
-  -- Modify the package database according to the command-line flags
-  -- (-package, -hide-package, -ignore-package, -hide-all-packages).
-  -- This needs to know about the unusable packages, since if a user tries
-  -- to enable an unusable package, we should let them know.
+  -- Compute a visibility map according to the command-line flags (-package,
+  -- -hide-package).  This needs to know about the unusable packages, since if a
+  -- user tries to enable an unusable package, we should let them know.
   --
-  (pkgs2, vis_map2) <- foldM (applyPackageFlag dflags unusable)
-                            (pkgs1, vis_map1) other_flags
+  vis_map2 <- foldM (applyPackageFlag dflags unusable pkgs1)
+                            vis_map1 other_flags
 
   --
   -- Sort out which packages are wired in. This has to be done last, since
   -- it modifies the unit ids of wired in packages, but when we process
-  -- package arguments we need to key against the old versions.  We also
-  -- have to update the visibility map in the process.
+  -- package arguments we need to key against the old versions.
   --
-  (pkgs3, vis_map, wired_map) <- findWiredInPackages dflags pkgs2 vis_map2
+  (pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2
+
+  -- Update the visibility map, so we treat wired packages as visible.
+  let vis_map = updateVisibilityMap wired_map vis_map2
 
   --
   -- Here we build up a set of the packages mentioned in -package
@@ -999,14 +1038,14 @@ mkPackageState dflags0 dbs preload0 = do
   --
   let preload1 = [ let key = unitId p
                    in fromMaybe key (Map.lookup key wired_map)
-                 | f <- flags, p <- get_exposed f ]
+                 | f <- other_flags, p <- get_exposed f ]
 
       get_exposed (ExposePackage a _) = take 1 . sortByVersion
                                       . filter (matching a)
-                                      $ pkgs2
+                                      $ pkgs1
       get_exposed _                 = []
 
-  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
+  let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
 
   let preload2 = preload1