Refactor PackageFlags so that ExposePackage is a single constructor.

You can parametrize over the different selection by using a
different PackageArg.  This helps reduce code duplication.

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

2 files changed, 39 insertions, 44 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 8280730747..d527e89dc9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -43,7 +43,7 @@ module DynFlags (
         targetRetainsAllBindings,
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,
-        PackageFlag(..),
+        PackageFlag(..), PackageArg(..),
         PkgConfRef(..),
         Option(..), showOpt,
         DynLibLoader(..),
@@ -1020,10 +1020,13 @@ isNoLink :: GhcLink -> Bool
 isNoLink NoLink = True
 isNoLink _      = False
 
+data PackageArg = PackageArg String
+                | PackageIdArg String
+                | PackageKeyArg String
+  deriving (Eq, Show)
+
 data PackageFlag
-  = ExposePackage   String
-  | ExposePackageId String
-  | ExposePackageKey String
+  = ExposePackage   PackageArg
   | HidePackage     String
   | IgnorePackage   String
   | TrustPackage    String
@@ -3343,13 +3346,20 @@ removeGlobalPkgConf = upd $ \s -> s { extraPkgConfs = filter isNotGlobal . extra
 clearPkgConf :: DynP ()
 clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] }
 
+parsePackageFlag :: (String -> PackageArg) -- type of argument
+                 -> String                 -- string to parse
+                 -> PackageFlag
+parsePackageFlag constr str = ExposePackage (constr str)
+
 exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage,
         trustPackage, distrustPackage :: String -> DynP ()
 exposePackage p = upd (exposePackage' p)
 exposePackageId p =
-  upd (\s -> s{ packageFlags = ExposePackageId p : packageFlags s })
+  upd (\s -> s{ packageFlags =
+    parsePackageFlag PackageIdArg p : packageFlags s })
 exposePackageKey p =
-  upd (\s -> s{ packageFlags = ExposePackageKey p : packageFlags s })
+  upd (\s -> s{ packageFlags =
+    parsePackageFlag PackageKeyArg p : packageFlags s })
 hidePackage p =
   upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })
 ignorePackage p =
@@ -3361,7 +3371,8 @@ distrustPackage p = exposePackage p >>
 
 exposePackage' :: String -> DynFlags -> DynFlags
 exposePackage' p dflags
-    = dflags { packageFlags = ExposePackage p : packageFlags dflags }
+    = dflags { packageFlags =
+            parsePackageFlag PackageArg p : packageFlags dflags }
 
 setPackageKey :: String -> DynFlags -> DynFlags
 setPackageKey p s =  s{ thisPackage = stringToPackageKey p }
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index bbf8752a25..122919bb7b 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -408,24 +408,8 @@ applyPackageFlag
 
 applyPackageFlag dflags unusable pkgs flag =
   case flag of
-    ExposePackage str ->
-       case selectPackages (matchingStr str) pkgs unusable of
-         Left ps         -> packageFlagErr dflags flag ps
-         Right (p:ps,qs) -> return (p':ps')
-          where p' = p {exposed=True}
-                ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
-         _ -> panic "applyPackageFlag"
-
-    ExposePackageId str ->
-       case selectPackages (matchingId str) pkgs unusable of
-         Left ps         -> packageFlagErr dflags flag ps
-         Right (p:ps,qs) -> return (p':ps')
-          where p' = p {exposed=True}
-                ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs)
-         _ -> panic "applyPackageFlag"
-
-    ExposePackageKey str ->
-       case selectPackages (matchingKey str) pkgs unusable of
+    ExposePackage arg ->
+       case selectPackages (matching arg) pkgs unusable of
          Left ps         -> packageFlagErr dflags flag ps
          Right (p:ps,qs) -> return (p':ps')
           where p' = p {exposed=True}
@@ -452,7 +436,7 @@ applyPackageFlag dflags unusable pkgs flag =
          Right (ps,qs) -> return (map distrust ps ++ qs)
           where distrust p = p {trusted=False}
 
-    _ -> panic "applyPackageFlag"
+    IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
 
    where
         -- When a package is requested to be exposed, we hide all other
@@ -493,6 +477,11 @@ matchingId str p =  InstalledPackageId str == installedPackageId p
 matchingKey :: String -> PackageConfig -> Bool
 matchingKey str p = str == display (packageKey p)
 
+matching :: PackageArg -> PackageConfig -> Bool
+matching (PackageArg str) = matchingStr str
+matching (PackageIdArg str) = matchingId str
+matching (PackageKeyArg str) = matchingKey str
+
 sortByVersion :: [InstalledPackageInfo_ m] -> [InstalledPackageInfo_ m]
 sortByVersion = sortBy (flip (comparing (pkgVersion.sourcePackageId)))
 
@@ -506,7 +495,7 @@ packageFlagErr :: DynFlags
 
 -- for missing DPH package we emit a more helpful error message, because
 -- this may be the result of using -fdph-par or -fdph-seq.
-packageFlagErr dflags (ExposePackage pkg) [] | is_dph_package pkg
+packageFlagErr dflags (ExposePackage (PackageArg pkg)) [] | is_dph_package pkg
   = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err))
   where dph_err = text "the " <> text pkg <> text " package is not installed."
                   $$ text "To install it: \"cabal install dph\"."
@@ -522,11 +511,13 @@ packageFlagErr dflags flag reasons
         ppr_flag = case flag of
                      IgnorePackage p -> text "-ignore-package " <> text p
                      HidePackage p   -> text "-hide-package " <> text p
-                     ExposePackage p -> text "-package " <> text p
-                     ExposePackageId p -> text "-package-id " <> text p
-                     ExposePackageKey p -> text "-package-key " <> text p
+                     ExposePackage a -> ppr_arg a
                      TrustPackage p    -> text "-trust " <> text p
                      DistrustPackage p -> text "-distrust " <> text p
+        ppr_arg arg = case arg of
+                     PackageArg    p -> text "-package " <> text p
+                     PackageIdArg  p -> text "-package-id " <> text p
+                     PackageKeyArg p -> text "-package-key " <> text p
         ppr_reasons = vcat (map ppr_reason reasons)
         ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason
 
@@ -831,15 +822,10 @@ mkPackageState dflags pkgs0 preload0 this_package = do
           -- XXX this is just a variant of nub
 
       ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
-      -- NB: Prefer the last one (i.e. the one highest in the package stack
-      pk_map = Map.fromList [ (packageConfigId p, p) | p <- pkgs0 ]
 
-      ipid_selected = depClosure ipid_map ([ InstalledPackageId i
-                                           | ExposePackageId i <- flags ]
-                                        ++ [ installedPackageId pkg
-                                           | ExposePackageKey k <- flags
-                                           , Just pkg <- [Map.lookup
-                                                (stringToPackageKey k) pk_map]])
+      ipid_selected = depClosure ipid_map
+                                 [ InstalledPackageId i
+                                 | ExposePackage (PackageIdArg i) <- flags ]
 
       (ignore_flags, other_flags) = partition is_ignore flags
       is_ignore IgnorePackage{} = True
@@ -870,12 +856,10 @@ mkPackageState dflags pkgs0 preload0 this_package = do
   --
   let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
 
-      get_exposed (ExposePackage   s)
-         = take 1 $ sortByVersion (filter (matchingStr s) pkgs2)
-         --  -package P means "the latest version of P" (#7030)
-      get_exposed (ExposePackageId s) = filter (matchingId  s) pkgs2
-      get_exposed (ExposePackageKey s) = filter (matchingKey s) pkgs2
-      get_exposed _                   = []
+      get_exposed (ExposePackage a) = take 1 . sortByVersion
+                                    . filter (matching a)
+                                    $ pkgs2
+      get_exposed _                 = []
 
   -- hide packages that are subsumed by later versions
   pkgs3 <- hideOldPackages dflags pkgs2