Support qualified module renamings

Qualified module renamings let you bring all modules from a library
into scope, but qualified under some module prefix.  If you write
'pkg qualified Prefix', then if pkg exposes A and B, you will be
able to access them as Prefix.A and Prefix.B.  This functionality
doesn't require any GHC changes; Cabal takes care of desugaring
the qualified syntax into an explicit list of renamings.

Partially address #7290

Signed-off-by: Edward Z. Yang <[email protected]>

Author: ezyang

Cabal/src/Distribution/Backpack/UnifyM.hs

@@ -487,6 +487,13 @@ convertInclude ci@(ComponentInclude {
     req_rename_list <-
       case req_rns of
         DefaultRenaming -> return []
+        QualifiedRenaming _ -> do
+            -- TODO: support this for requires (req_rename_list
+            -- is a bad representation for this, alas, need
+            -- a bigger refactor here)
+            addErr $ text "Unsupported syntax" <+>
+                     quotes (text "requires qualified (...)")
+            return []
         HidingRenaming _ -> do
             -- Not valid here for requires!
             addErr $ text "Unsupported syntax" <+>
@@ -561,6 +568,12 @@ convertInclude ci@(ComponentInclude {
     (pre_prov_scope, prov_rns') <-
         case prov_rns of
             DefaultRenaming -> return (Map.toList provs, prov_rns)
+            QualifiedRenaming prefix ->
+                let prov_scope0 = [ (prefix `joinModuleName` k,v) | (k,v) <- Map.toList provs ]
+                    prov_rns0 = [ (k, prefix `joinModuleName` k) | (k,_) <- Map.toList provs  ]
+                    -- GHC doesn't understand qualification, so return
+                    -- the expanded version
+                    in return (prov_scope0, ModuleRenaming prov_rns0)
             HidingRenaming hides ->
                 let hides_set = Set.fromList hides
                 in let r = [ (k,v)

Cabal/src/Distribution/ModuleName.hs

@@ -18,6 +18,7 @@ module Distribution.ModuleName (
         fromString,
         fromComponents,
         components,
+        joinModuleName,
         toFilePath,
         main,
         -- * Internal
@@ -44,6 +45,12 @@ newtype ModuleName = ModuleName ShortText
 unModuleName :: ModuleName -> String
 unModuleName (ModuleName s) = fromShortText s
 
+-- Guaranteed to be valid by invariants on the initial module
+-- names (in particular, empty module name is not valid)
+joinModuleName :: ModuleName -> ModuleName -> ModuleName
+joinModuleName a b =
+  ModuleName (toShortText (unModuleName a ++ "." ++ unModuleName b))
+
 instance Binary ModuleName
 instance Structured ModuleName
 

Cabal/src/Distribution/Types/ModuleRenaming.hs

@@ -41,6 +41,11 @@ data ModuleRenaming
         -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all
         -- exported modules into scope except the hidden ones.
         | HidingRenaming [ModuleName]
+        -- | Qualified renaming, @(qualified P)@, brining all
+        -- exported modules into scope with P prefix.  So if M
+        -- was provided by the package, it is now in scope as
+        -- P.M
+        | QualifiedRenaming ModuleName
     deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
 
 -- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName'
@@ -54,6 +59,8 @@ interpModuleRenaming (ModuleRenaming rns) =
 interpModuleRenaming (HidingRenaming hs) =
     let s = Set.fromList hs
     in \k -> if k `Set.member` s then Nothing else Just k
+interpModuleRenaming (QualifiedRenaming prefix) =
+    \k -> Just (prefix `joinModuleName` k)
 
 -- | The default renaming, if something is specified in @build-depends@
 -- only.
@@ -79,6 +86,8 @@ instance Pretty ModuleRenaming where
   pretty DefaultRenaming = mempty
   pretty (HidingRenaming hides)
         = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides)))
+  pretty (QualifiedRenaming prefix)
+        = text "qualified" <+> pretty prefix
   pretty (ModuleRenaming rns)
         = parens . hsep $ punctuate comma (map dispEntry rns)
     where dispEntry (orig, new)
@@ -109,7 +118,7 @@ moduleRenamingParsec
     -> m ModuleRenaming
 moduleRenamingParsec bp mn =
     -- NB: try not necessary as the first token is obvious
-    P.choice [ parseRename, parseHiding, return DefaultRenaming ]
+    P.choice [ parseRename, parseHiding, parseQualified, return DefaultRenaming ]
   where
     cma = P.char ',' >> P.spaces
     parseRename = do
@@ -121,6 +130,11 @@ moduleRenamingParsec bp mn =
         P.spaces -- space isn't strictly required as next is an open paren
         hides <- bp (P.sepBy mn cma)
         return (HidingRenaming hides)
+    parseQualified = do
+        _ <- P.string "qualified"
+        P.spaces
+        prefix <- mn
+        return (QualifiedRenaming prefix)
     parseList =
         P.sepBy parseEntry cma
     parseEntry = do

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/A.hs

@@ -0,0 +1,2 @@
+module A where
+import Prefix.Quxbaz

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/QualifiedIncludes.cabal

@@ -0,0 +1,19 @@
+name:                QualifiedIncludes
+version:             0.1.0.0
+license:             BSD3
+author:              Edward Z. Yang
+maintainer:          [email protected]
+build-type:          Simple
+cabal-version:       2.0
+
+library impl
+  build-depends: base
+  exposed-modules: Foobar, Quxbaz
+  hs-source-dirs: impl
+  default-language:    Haskell2010
+
+library good
+  build-depends: base, impl
+  mixins: impl qualified Prefix
+  exposed-modules: A
+  default-language:    Haskell2010

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Foobar.hs

@@ -0,0 +1 @@
+module Foobar where

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/impl/Quxbaz.hs

@@ -0,0 +1 @@
+module Quxbaz where

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.cabal.out

@@ -0,0 +1,9 @@
+# Setup configure
+Configuring Includes5-0.1.0.0...
+# Setup build
+Preprocessing library 'impl' for Includes5-0.1.0.0..
+Building library 'impl' for Includes5-0.1.0.0..
+Preprocessing library 'good' for Includes5-0.1.0.0..
+Building library 'good' for Includes5-0.1.0.0..
+Preprocessing library 'bad' for Includes5-0.1.0.0..
+Building library 'bad' for Includes5-0.1.0.0..

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.out

@@ -0,0 +1,7 @@
+# Setup configure
+Configuring QualifiedIncludes-0.1.0.0...
+# Setup build
+Preprocessing library 'impl' for QualifiedIncludes-0.1.0.0..
+Building library 'impl' for QualifiedIncludes-0.1.0.0..
+Preprocessing library 'good' for QualifiedIncludes-0.1.0.0..
+Building library 'good' for QualifiedIncludes-0.1.0.0..

cabal-testsuite/PackageTests/Backpack/QualifiedIncludes/setup.test.hs

@@ -0,0 +1,6 @@
+import Test.Cabal.Prelude
+main = setupAndCabalTest $ do
+    skipUnlessGhcVersion ">= 8.1"
+    setup "configure" []
+    setup "build" []
+    return ()