Revert "Revert "Merge pull request haskell#4382 from Ericson2314/munge""

This reverts commit 4774fb6.

Author: ezyang

Cabal/Cabal.cabal

@@ -219,6 +219,7 @@ library
     Distribution.Types.PkgconfigDependency
     Distribution.Types.DependencyMap
     Distribution.Types.ComponentId
+    Distribution.Types.MungedPackageId
     Distribution.Types.PackageId
     Distribution.Types.UnitId
     Distribution.Types.Executable
@@ -230,6 +231,7 @@ library
     Distribution.Types.ModuleReexport
     Distribution.Types.ModuleRenaming
     Distribution.Types.ComponentName
+    Distribution.Types.MungedPackageName
     Distribution.Types.PackageName
     Distribution.Types.PkgconfigName
     Distribution.Types.UnqualComponentName

Cabal/Distribution/Backpack/Configure.hs

@@ -39,6 +39,7 @@ import Distribution.Simple.Setup as Setup
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Types.ComponentRequestedSpec
 import Distribution.Types.ComponentInclude
+import Distribution.Types.MungedPackageId
 import Distribution.Verbosity
 import qualified Distribution.Compat.Graph as Graph
 import Distribution.Compat.Graph (Graph, IsNode(..))
@@ -81,7 +82,7 @@ configureComponentLocalBuildInfos
                         (dispComponentsGraph graph0)
 
     let conf_pkg_map = Map.fromListWith Map.union
-            [(pc_pkgname pkg, Map.singleton (pc_compname pkg) (pc_cid pkg, pc_pkgid pkg))
+            [(pc_pkgname pkg, Map.singleton (pc_compname pkg) (pc_cid pkg, packageId pkg))
             | pkg <- prePkgDeps]
     graph1 <- toConfiguredComponents use_external_internal_deps
                     flagAssignment
@@ -107,9 +108,9 @@ configureComponentLocalBuildInfos
              (vcat (map dispLinkedComponent graph2))
 
     let pid_map = Map.fromList $
-            [ (pc_uid pkg, pc_pkgid pkg)
+            [ (pc_uid pkg, pc_munged_id pkg)
             | pkg <- prePkgDeps] ++
-            [ (Installed.installedUnitId pkg, Installed.sourcePackageId pkg)
+            [ (Installed.installedUnitId pkg, Installed.sourceMungedPackageId pkg)
             | (_, Module uid _) <- instantiate_with
             , Just pkg <- [PackageIndex.lookupUnitId
                                 installedPackageSet (unDefUnitId uid)] ]
@@ -204,12 +205,12 @@ toComponentLocalBuildInfos
     -- TODO: This is probably wrong for Backpack
     let pseudoTopPkg :: InstalledPackageInfo
         pseudoTopPkg = emptyInstalledPackageInfo {
-            Installed.installedUnitId =
-               mkLegacyUnitId (packageId pkg_descr),
-            Installed.sourcePackageId = packageId pkg_descr,
-            Installed.depends =
-              map pc_uid externalPkgDeps
+            Installed.installedUnitId = mkLegacyUnitId munged_id,
+            Installed.sourceMungedPackageId = munged_id,
+            Installed.depends = map pc_uid externalPkgDeps
           }
+          where munged_id = computeCompatPackageId (packageId pkg_descr)
+                                                   CLibName
     case PackageIndex.dependencyInconsistencies
        . PackageIndex.insert pseudoTopPkg
        $ packageDependsIndex of

Cabal/Distribution/Backpack/ConfiguredComponent.hs

@@ -99,7 +99,7 @@ mkConfiguredComponent pkg_decr this_cid lib_deps exe_deps component = do
     -- Resolve each @mixins@ into the actual dependency
     -- from @lib_deps@.
     explicit_includes <- forM (mixins bi) $ \(Mixin name rns) -> do
-        let keys = fixFakePkgName pkg_decr name
+        let keys@(_, cname) = fixFakePkgName pkg_decr name
         (cid, pid) <-
             case Map.lookup keys deps_map of
                 Nothing ->
@@ -110,10 +110,8 @@ mkConfiguredComponent pkg_decr this_cid lib_deps exe_deps component = do
                 Just r  -> return r
         return ComponentInclude {
                 ci_id       = cid,
-                -- TODO: We set pkgName = name here to make error messages
-                -- look better. But it would be better to properly
-                -- record component name here.
-                ci_pkgid    = pid { pkgName = name },
+                ci_pkgid    = pid,
+                ci_compname = cname,
                 ci_renaming = rns,
                 ci_implicit = False
             }
@@ -122,10 +120,10 @@ mkConfiguredComponent pkg_decr this_cid lib_deps exe_deps component = do
         -- @backpack-include@ is converted into an "implicit" include.
     let used_explicitly = Set.fromList (map ci_id explicit_includes)
         implicit_includes
-            = map (\((pn, _), (cid, pid)) -> ComponentInclude {
+            = map (\((_, cn), (cid, pid)) -> ComponentInclude {
                                     ci_id = cid,
-                                    -- See above ci_pkgid
-                                    ci_pkgid = pid { pkgName = pn },
+                                    ci_pkgid = pid,
+                                    ci_compname = cn,
                                     ci_renaming = defaultIncludeRenaming,
                                     ci_implicit = True
                                   })

Cabal/Distribution/Backpack/Id.hs

@@ -20,7 +20,7 @@ import Distribution.Simple.LocalBuildInfo
 import Distribution.Types.ComponentId
 import Distribution.Types.PackageId
 import Distribution.Types.UnitId
-import Distribution.Types.PackageName
+import Distribution.Types.MungedPackageName
 import Distribution.Utils.Base62
 import Distribution.Version
 
@@ -71,55 +71,6 @@ computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =
                                 Nothing -> ""
                                 Just s -> "-" ++ unUnqualComponentName s)
 
--- | Computes the package name for a library.  If this is the public
--- library, it will just be the original package name; otherwise,
--- it will be a munged package name recording the original package
--- name as well as the name of the internal library.
---
--- A lot of tooling in the Haskell ecosystem assumes that if something
--- is installed to the package database with the package name 'foo',
--- then it actually is an entry for the (only public) library in package
--- 'foo'.  With internal packages, this is not necessarily true:
--- a public library as well as arbitrarily many internal libraries may
--- come from the same package.  To prevent tools from getting confused
--- in this case, the package name of these internal libraries is munged
--- so that they do not conflict the public library proper.  A particular
--- case where this matters is ghc-pkg: if we don't munge the package
--- name, the inplace registration will OVERRIDE a different internal
--- library.
---
--- We munge into a reserved namespace, "z-", and encode both the
--- component name and the package name of an internal library using the
--- following format:
---
---      compat-pkg-name ::= "z-" package-name "-z-" library-name
---
--- where package-name and library-name have "-" ( "z" + ) "-"
--- segments encoded by adding an extra "z".
---
--- When we have the public library, the compat-pkg-name is just the
--- package-name, no surprises there!
---
-computeCompatPackageName :: PackageName -> ComponentName -> PackageName
--- First handle the cases where we can just use the original 'PackageName'.
--- This is for the PRIMARY library, and it is non-Backpack, or the
--- indefinite package for us.
-computeCompatPackageName pkg_name CLibName = pkg_name
-computeCompatPackageName pkg_name cname
-    = mkPackageName $ "z-" ++ zdashcode (display pkg_name)
-                 ++ (case componentNameString cname of
-                        Just cname_u -> "-z-" ++ zdashcode cname_str
-                          where cname_str = unUnqualComponentName cname_u
-                        Nothing -> "")
-
-zdashcode :: String -> String
-zdashcode s = go s (Nothing :: Maybe Int) []
-    where go [] _ r = reverse r
-          go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)
-          go ('-':z) _        r = go z (Just 0) ('-':r)
-          go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)
-          go (c:z)   _        r = go z Nothing (c:r)
-
 -- | In GHC 8.0, the string we pass to GHC to use for symbol
 -- names for a package can be an arbitrary, IPID-compatible string.
 -- However, prior to GHC 8.0 there are some restrictions on what
@@ -169,7 +120,7 @@ zdashcode s = go s (Nothing :: Maybe Int) []
 --
 computeCompatPackageKey
     :: Compiler
-    -> PackageName
+    -> MungedPackageName
     -> Version
     -> UnitId
     -> String

Cabal/Distribution/Backpack/LinkedComponent.hs

@@ -29,6 +29,7 @@ import Distribution.Types.ModuleRenaming
 import Distribution.Types.IncludeRenaming
 import Distribution.Types.ComponentInclude
 import Distribution.Types.ComponentId
+import Distribution.Types.MungedPackageId
 import Distribution.Types.PackageId
 import Distribution.Package
 import Distribution.PackageDescription as PD hiding (Flag)
@@ -105,6 +106,10 @@ dispLinkedComponent lc =
 instance Package LinkedComponent where
     packageId = lc_pkgid
 
+instance HasMungedPackageId LinkedComponent where
+    mungedId LinkedComponent { lc_pkgid = pkgid, lc_component = component }
+      = computeCompatPackageId pkgid (componentName component)
+
 toLinkedComponent
     :: Verbosity
     -> FullDb
@@ -137,8 +142,8 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
         -- *unlinked* unit identity.  We will use unification (relying
         -- on the ModuleShape) to resolve these into linked identities.
         unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
-        unlinked_includes = [ ComponentInclude (lookupUid cid) pid rns i
-                            | ComponentInclude cid pid rns i <- cid_includes ]
+        unlinked_includes = [ ComponentInclude (lookupUid cid) pid cn rns i
+                            | ComponentInclude cid pid cn rns i <- cid_includes ]
 
         lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
         lookupUid cid = fromMaybe (error "linkComponent: lookupUid")
@@ -178,11 +183,12 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
         -- src_reqs_u <- mapM convertReq src_reqs
         -- Read out all the final results by converting back
         -- into a pure representation.
-        let convertIncludeU (ComponentInclude uid_u pid rns i) = do
+        let convertIncludeU (ComponentInclude uid_u pid cn rns i) = do
                 uid <- convertUnitIdU uid_u
                 return (ComponentInclude {
                             ci_id = uid,
                             ci_pkgid = pid,
+                            ci_compname = cn,
                             ci_renaming = rns,
                             ci_implicit = i
                         })

Cabal/Distribution/Backpack/PreExistingComponent.hs

@@ -10,6 +10,7 @@ import Distribution.Compat.Prelude
 import Distribution.Backpack.ModuleShape
 import Distribution.Backpack
 import Distribution.Types.ComponentId
+import Distribution.Types.MungedPackageId
 import Distribution.Types.PackageId
 import Distribution.Types.UnitId
 import Distribution.Types.ComponentName
@@ -31,7 +32,7 @@ data PreExistingComponent
         pc_pkgname :: PackageName,
         -- | The actual name of the component.
         pc_compname :: ComponentName,
-        pc_pkgid :: PackageId,
+        pc_munged_id :: MungedPackageId,
         pc_uid   :: UnitId,
         pc_cid   :: ComponentId,
         pc_open_uid :: OpenUnitId,
@@ -44,11 +45,9 @@ data PreExistingComponent
 ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent
 ipiToPreExistingComponent ipi =
     PreExistingComponent {
-        pc_pkgname = case Installed.sourcePackageName ipi of
-            Just n -> n
-            Nothing -> pkgName $ Installed.sourcePackageId ipi,
+        pc_pkgname = Installed.sourcePackageName' ipi,
         pc_compname = libraryComponentName $ Installed.sourceLibName ipi,
-        pc_pkgid = Installed.sourcePackageId ipi,
+        pc_munged_id = Installed.sourceMungedPackageId ipi,
         pc_uid   = Installed.installedUnitId ipi,
         pc_cid   = Installed.installedComponentId ipi,
         pc_open_uid =
@@ -57,8 +56,12 @@ ipiToPreExistingComponent ipi =
         pc_shape = shapeInstalledPackage ipi
     }
 
+instance HasMungedPackageId PreExistingComponent where
+  mungedId = pc_munged_id
+
 instance Package PreExistingComponent where
-  packageId = pc_pkgid
+  packageId pec = PackageIdentifier (pc_pkgname pec) v
+    where MungedPackageId _ v = pc_munged_id pec
 
 instance HasUnitId PreExistingComponent where
   installedUnitId = pc_uid

Cabal/Distribution/Backpack/ReadyComponent.hs

@@ -28,7 +28,8 @@ import Distribution.Types.PackageId
 import Distribution.Types.UnitId
 import Distribution.Compat.Graph (IsNode(..))
 import Distribution.Types.Module
-import Distribution.Types.PackageName
+import Distribution.Types.MungedPackageId
+import Distribution.Types.MungedPackageName
 
 import Distribution.ModuleName
 import Distribution.Package
@@ -91,7 +92,7 @@ data InstantiatedComponent
         -- | Dependencies induced by 'instc_insts'.  These are recorded
         -- here because there isn't a convenient way otherwise to get
         -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.
-        instc_insts_deps :: [(UnitId, PackageId)],
+        instc_insts_deps :: [(UnitId, MungedPackageId)],
         -- | The modules exported/reexported by this library.
         instc_provides :: Map ModuleName Module,
         -- | The dependencies which need to be passed to the compiler
@@ -116,20 +117,27 @@ data IndefiniteComponent
 
 -- | Compute the dependencies of a 'ReadyComponent' that should
 -- be recorded in the @depends@ field of 'InstalledPackageInfo'.
-rc_depends :: ReadyComponent -> [(UnitId, PackageId)]
+rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)]
 rc_depends rc = ordNub $
     case rc_i rc of
         Left indefc ->
-            map (\ci -> (abstractUnitId (ci_id ci), ci_pkgid ci))
+            map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))
                 (indefc_includes indefc)
         Right instc ->
-            map (\ci -> (unDefUnitId (ci_id ci), ci_pkgid ci))
+            map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))
                 (instc_includes instc)
               ++ instc_insts_deps instc
+  where
+    toMungedPackageId :: ComponentInclude x y -> MungedPackageId
+    toMungedPackageId ci = computeCompatPackageId (ci_pkgid ci) (ci_compname ci)
 
 instance Package ReadyComponent where
     packageId = rc_pkgid
 
+instance HasMungedPackageId ReadyComponent where
+    mungedId ReadyComponent { rc_pkgid = pkgid, rc_component = component }
+      = computeCompatPackageId pkgid (componentName component)
+
 instance HasUnitId ReadyComponent where
     installedUnitId = rc_uid
 
@@ -146,8 +154,8 @@ instance IsNode ReadyComponent where
       ordNub (map fst (rc_depends rc)) ++
       map fst (rc_exe_deps rc)
 
-rc_compat_name :: ReadyComponent -> PackageName
-rc_compat_name ReadyComponent{
+rc_compat_name :: ReadyComponent -> MungedPackageName
+rc_compat_name ReadyComponent {
         rc_pkgid = PackageIdentifier pkg_name _,
         rc_component = component
     }
@@ -213,7 +221,7 @@ instance Monad InstM where
 -- instantiated components are given 'HashedUnitId'.
 --
 toReadyComponents
-    :: Map UnitId PackageId
+    :: Map UnitId MungedPackageId
     -> Map ModuleName Module -- subst for the public component
     -> [LinkedComponent]
     -> [ReadyComponent]
@@ -257,11 +265,10 @@ toReadyComponents pid_map subst0 comps
                     = [(dep_uid,
                           fromMaybe err_pid $
                             Map.lookup dep_uid pid_map A.<|>
-                            fmap rc_pkgid (join (Map.lookup dep_uid s)))]
+                            fmap mungedId (join (Map.lookup dep_uid s)))]
                   where
-                    err_pid =
-                      PackageIdentifier
-                        (mkPackageName "nonexistent-package-this-is-a-cabal-bug")
+                    err_pid = MungedPackageId
+                        (mkMungedPackageName "nonexistent-package-this-is-a-cabal-bug")
                         (mkVersion [0])
                 instc = InstantiatedComponent {
                             instc_insts = Map.toList insts,

Cabal/Distribution/Backpack/UnifyM.hs

@@ -450,6 +450,7 @@ convertInclude
 convertInclude ci@(ComponentInclude {
                     ci_id = (uid, ModuleShape provs reqs),
                     ci_pkgid = pid,
+                    ci_compname = compname,
                     ci_renaming = incl@(IncludeRenaming prov_rns req_rns),
                     ci_implicit = implicit
                }) = addErrContext (text "In" <+> ci_msg ci) $ do
@@ -587,6 +588,7 @@ convertInclude ci@(ComponentInclude {
                     else Left) (ComponentInclude {
                                     ci_id = uid_u,
                                     ci_pkgid = pid,
+                                    ci_compname = compname,
                                     ci_renaming = prov_rns',
                                     ci_implicit = ci_implicit ci
                                     }))