Distinguish between true package names, and munged package names

There should be little-to-no functional changes with this commit

Author: Ericson2314

Cabal/Cabal.cabal

@@ -219,6 +219,7 @@ library
     Distribution.Types.PkgconfigDependency
     Distribution.Types.DependencyMap
     Distribution.Types.ComponentId
+    Distribution.Types.MungedId
     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.MungedName
     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.MungedId
 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.fromList
-            [((pc_pkgname pkg, pc_compname pkg), (pc_cid pkg, pc_pkgid pkg))
+            [((pc_pkgname pkg, 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.sourceMungedId 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.sourceMungedId = 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

@@ -108,18 +108,17 @@ mkConfiguredComponent pkg_decr this_cid lib_deps exe_deps component =
     -- Resolve each @mixins@ into the actual dependency
     -- from @lib_deps@.
     explicit_includes
-        = [ let (cid, pid) =
-                    case Map.lookup (fixFakePkgName pkg_decr name) deps_map of
+        = [ let keys@(_, cname) = fixFakePkgName pkg_decr name
+                (cid, pid) =
+                    case Map.lookup keys deps_map of
                         Nothing ->
                             error $ "Mix-in refers to non-existent package " ++ display name ++
                                     " (did you forget to add the package to build-depends?)"
                         Just r  -> r
             in 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
                }
@@ -129,10 +128,10 @@ mkConfiguredComponent pkg_decr this_cid lib_deps exe_deps component =
     -- @backpack-include@ is converted into an "implicit" include.
     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.MungedName
 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
+    -> MungedName
     -> 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.MungedId
 import Distribution.Types.PackageId
 import Distribution.Package
 import Distribution.PackageDescription as PD hiding (Flag)
@@ -106,6 +107,10 @@ dispLinkedComponent lc =
 instance Package LinkedComponent where
     packageId = lc_pkgid
 
+instance HasMungedId LinkedComponent where
+    mungedId LinkedComponent { lc_pkgid = pkgid, lc_component = component }
+      = computeCompatPackageId pkgid (componentName component)
+
 toLinkedComponent
     :: Verbosity
     -> FullDb
@@ -138,8 +143,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")
@@ -179,11 +184,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,9 +10,11 @@ import Distribution.Compat.Prelude
 import Distribution.Backpack.ModuleShape
 import Distribution.Backpack
 import Distribution.Types.ComponentId
+import Distribution.Types.MungedId
 import Distribution.Types.PackageId
 import Distribution.Types.UnitId
 import Distribution.Types.ComponentName
+import Distribution.Types.MungedName
 import Distribution.Types.PackageName
 import Distribution.Package
 
@@ -31,7 +33,7 @@ data PreExistingComponent
         pc_pkgname :: PackageName,
         -- | The actual name of the component.
         pc_compname :: ComponentName,
-        pc_pkgid :: PackageId,
+        pc_munged_id :: MungedId,
         pc_uid   :: UnitId,
         pc_cid   :: ComponentId,
         pc_open_uid :: OpenUnitId,
@@ -46,9 +48,10 @@ ipiToPreExistingComponent ipi =
     PreExistingComponent {
         pc_pkgname = case Installed.sourcePackageName ipi of
             Just n -> n
-            Nothing -> pkgName $ Installed.sourcePackageId ipi,
+            Nothing -> mkPackageName $ unMungedName
+              $ mungedName $ Installed.sourceMungedId ipi,
         pc_compname = libraryComponentName $ Installed.sourceLibName ipi,
-        pc_pkgid = Installed.sourcePackageId ipi,
+        pc_munged_id = Installed.sourceMungedId ipi,
         pc_uid   = Installed.installedUnitId ipi,
         pc_cid   = Installed.installedComponentId ipi,
         pc_open_uid =
@@ -57,8 +60,12 @@ ipiToPreExistingComponent ipi =
         pc_shape = shapeInstalledPackage ipi
     }
 
+instance HasMungedId PreExistingComponent where
+  mungedId = pc_munged_id
+
 instance Package PreExistingComponent where
-  packageId = pc_pkgid
+  packageId pec = PackageIdentifier (pc_pkgname pec) v
+    where MungedId _ 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.MungedId
+import Distribution.Types.MungedName
 
 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, MungedId)],
         -- | 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, MungedId)]
 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, toMungedId ci))
                 (indefc_includes indefc)
         Right instc ->
-            map (\ci -> (unDefUnitId (ci_id ci), ci_pkgid ci))
+            map (\ci -> (unDefUnitId $ ci_id ci, toMungedId ci))
                 (instc_includes instc)
               ++ instc_insts_deps instc
+  where
+    toMungedId :: ComponentInclude x y -> MungedId
+    toMungedId ci = computeCompatPackageId (ci_pkgid ci) (ci_compname ci)
 
 instance Package ReadyComponent where
     packageId = rc_pkgid
 
+instance HasMungedId ReadyComponent where
+    mungedId ReadyComponent { rc_pkgid = pkgid, rc_component = component }
+      = computeCompatPackageId pkgid (componentName component)
+
 instance HasUnitId ReadyComponent where
     installedUnitId = rc_uid
 
@@ -145,8 +153,8 @@ instance IsNode ReadyComponent where
         _ -> []) ++
       ordNub (map fst (rc_depends rc))
 
-rc_compat_name :: ReadyComponent -> PackageName
-rc_compat_name ReadyComponent{
+rc_compat_name :: ReadyComponent -> MungedName
+rc_compat_name ReadyComponent {
         rc_pkgid = PackageIdentifier pkg_name _,
         rc_component = component
     }
@@ -212,7 +220,7 @@ instance Monad InstM where
 -- instantiated components are given 'HashedUnitId'.
 --
 toReadyComponents
-    :: Map UnitId PackageId
+    :: Map UnitId MungedId
     -> Map ModuleName Module -- subst for the public component
     -> [LinkedComponent]
     -> [ReadyComponent]
@@ -256,11 +264,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 = MungedId
+                        (mkMungedName "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
                                     }))