Support for "with" renaming syntax, and output a feature flag.

Summary:
- Feature flag indicates to Cabal that we support thinning and renaming as
  it needs.

- Support -package "base with (Foo as Bar)" which brings the ordinary
  modules into scope, as well as adding the renamings to scope.

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

Test Plan: validate

Reviewers: simonpj, austin

Subscribers: thomie, carter

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

4 files changed, 32 insertions, 30 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 043174f3b0..7aaebfa711 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -43,7 +43,7 @@ module DynFlags (
         targetRetainsAllBindings,
         GhcMode(..), isOneShot,
         GhcLink(..), isNoLink,
-        PackageFlag(..), PackageArg(..), ModRenaming,
+        PackageFlag(..), PackageArg(..), ModRenaming(..),
         PkgConfRef(..),
         Option(..), showOpt,
         DynLibLoader(..),
@@ -1059,7 +1059,8 @@ data PackageArg = PackageArg String
                 | PackageKeyArg String
   deriving (Eq, Show)
 
-type ModRenaming = Maybe [(String, String)]
+data ModRenaming = ModRenaming Bool [(String, String)]
+  deriving (Eq, Show)
 
 data PackageFlag
   = ExposePackage   PackageArg ModRenaming
@@ -3440,13 +3441,15 @@ parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of
     [(r, "")] -> r
     _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)
   where parse = do
-            pkg <- munch1 (\c -> isAlphaNum c || c `elem` ":-_.")
-            (do _ <- tok $ R.char '('
-                rns <- tok $ sepBy parseItem (tok $ R.char ',')
-                _ <- tok $ R.char ')'
-                return (ExposePackage (constr pkg) (Just rns))
-              +++
-             return (ExposePackage (constr pkg) Nothing))
+            pkg <- tok $ munch1 (\c -> isAlphaNum c || c `elem` ":-_.")
+            ( do _ <- tok $ string "with"
+                 fmap (ExposePackage (constr pkg) . ModRenaming True) parseRns
+             <++ fmap (ExposePackage (constr pkg) . ModRenaming False) parseRns
+             <++ return (ExposePackage (constr pkg) (ModRenaming True [])))
+        parseRns = do _ <- tok $ R.char '('
+                      rns <- tok $ sepBy parseItem (tok $ R.char ',')
+                      _ <- tok $ R.char ')'
+                      return rns
         parseItem = do
             orig <- tok $ parseModuleName
             (do _ <- tok $ string "as"
@@ -3454,7 +3457,7 @@ parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of
                 return (orig, new)
               +++
              return (orig, orig))
-        tok m = skipSpaces >> m
+        tok m = m >>= \x -> skipSpaces >> return x
 
 exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage,
         trustPackage, distrustPackage :: String -> DynP ()
@@ -3723,6 +3726,7 @@ compilerInfo dflags
        ("Support dynamic-too",         if isWindows then "NO" else "YES"),
        ("Support parallel --make",     "YES"),
        ("Support reexported-modules",  "YES"),
+       ("Support thinning and renaming package flags", "YES"),
        ("Uses package keys",           "YES"),
        ("Dynamic by default",          if dYNAMIC_BY_DEFAULT dflags
                                        then "YES" else "NO"),
diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs
index 519353e0bb..2f4a4d7663 100644
--- a/compiler/main/Packages.lhs
+++ b/compiler/main/Packages.lhs
@@ -477,26 +477,19 @@ applyPackageFlag
 
 applyPackageFlag dflags unusable (pkgs, vm) flag =
   case flag of
-    ExposePackage arg m_rns ->
+    ExposePackage arg (ModRenaming b rns) ->
        case selectPackages (matching arg) pkgs unusable of
          Left ps         -> packageFlagErr dflags flag ps
          Right (p:_,_) -> return (pkgs, vm')
           where
            n = fsPackageName p
-           vm' = addToUFM_C edit vm_cleared (calcKey p)
-                              (case m_rns of
-                                   Nothing   -> (True, [], n)
-                                   Just rns' -> (False, map convRn rns', n))
+           vm' = addToUFM_C edit vm_cleared (calcKey p) (b, map convRn rns, n)
            edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
            convRn (a,b) = (mkModuleName a, mkModuleName b)
            -- ToDo: ATM, -hide-all-packages implicitly triggers change in
            -- behavior, maybe eventually make it toggleable with a separate
            -- flag
            vm_cleared | gopt Opt_HideAllPackages dflags = vm
-                      -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide
-                      -- other versions of foo. Presence of renaming means
-                      -- user probably wanted both.
-                      | Just _ <- m_rns = vm
                       | otherwise = filterUFM_Directly
                             (\k (_,_,n') -> k == getUnique (calcKey p)
                                                 || n /= n') vm
@@ -594,9 +587,10 @@ pprFlag flag = case flag of
                      PackageArg    p -> text "-package " <> text p
                      PackageIdArg  p -> text "-package-id " <> text p
                      PackageKeyArg p -> text "-package-key " <> text p
-        ppr_rns Nothing = Outputable.empty
-        ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns))
-                                      <> char ')'
+        ppr_rns (ModRenaming True []) = Outputable.empty
+        ppr_rns (ModRenaming b rns) =
+            if b then text "with" else Outputable.empty <+>
+            char '(' <> hsep (punctuate comma (map ppr_rn rns)) <> char ')'
         ppr_rn (orig, new) | orig == new = text orig
                            | otherwise = text orig <+> text "as" <+> text new
 
diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml
index 7a4734d224..15ce719939 100644
--- a/docs/users_guide/packages.xml
+++ b/docs/users_guide/packages.xml
@@ -390,13 +390,14 @@ _ZCMain_main_closure
   parenthesized, comma-separated list of module names to import.  For example,
   <literal>-package "base (Data.List, Data.Bool)"</literal> makes only
   <literal>Data.List</literal> and <literal>Data.Bool</literal> visible from
-  package <literal>base</literal>.
-  We also support renaming of modules, in case you need to refer to both modules
-  simultaneously; this is supporting by writing <literal>OldModName as
-  NewModName</literal>, e.g. <literal>-package "base (Data.Bool as
-  Bool)</literal>. It's important to specify quotes
-  so that your shell passes the package name and thinning/renaming list as a
-  single argument to GHC.</para>
+  package <literal>base</literal>.  We also support renaming of modules, in case
+  you need to refer to both modules simultaneously; this is supporting by
+  writing <literal>OldModName as NewModName</literal>, e.g. <literal>-package
+  "base (Data.Bool as Bool)</literal>.  You can also write <literal>-package
+  "base with (Data.Bool as Bool)</literal> to include all of the original
+  bindings (e.g. the renaming is strictly additive).  It's important to specify
+  quotes so that your shell passes the package name and thinning/renaming list
+  as a single argument to GHC.</para>
 
   <para>Package imports with thinning/renaming do not hide other versions of the
   package: e.g. if containers-0.9 is already exposed, <literal>-package
diff --git a/testsuite/tests/ghc-api/T9595.hs b/testsuite/tests/ghc-api/T9595.hs
index b6c336ab9a..d4e01d070c 100644
--- a/testsuite/tests/ghc-api/T9595.hs
+++ b/testsuite/tests/ghc-api/T9595.hs
@@ -17,7 +17,10 @@ main =
                 liftIO $ print (mkModuleName "Outputable" `elem` listVisibleModuleNames dflags)
      _ <- runGhc (Just libdir) $ do
                 dflags <- getSessionDynFlags
-                setSessionDynFlags (dflags { packageFlags = [ExposePackage (PackageArg "ghc") Nothing]})
+                setSessionDynFlags (dflags {
+                    packageFlags = [ExposePackage (PackageArg "ghc")
+                                                  (ModRenaming True [])]
+                    })
                 dflags <- getSessionDynFlags
                 liftIO $ print (mkModuleName "Outputable" `elem` listVisibleModuleNames dflags)
      return ()