Add mkLegacyUnitId and use it where appropriate.

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

Cabal/Distribution/Package.hs

@@ -26,6 +26,7 @@ module Distribution.Package (
         ComponentId(..),
         UnitId(..),
         mkUnitId,
+        mkLegacyUnitId,
         getHSLibraryName,
         InstalledPackageId, -- backwards compat
 
@@ -147,6 +148,10 @@ newtype UnitId = SimpleUnitId ComponentId
 mkUnitId :: String -> UnitId
 mkUnitId = SimpleUnitId . ComponentId
 
+-- | Make an old-style UnitId from a package identifier
+mkLegacyUnitId :: PackageId -> UnitId
+mkLegacyUnitId = SimpleUnitId . ComponentId . display
+
 -- ------------------------------------------------------------
 -- * Package source dependencies
 -- ------------------------------------------------------------

Cabal/Distribution/Simple/Configure.hs

@@ -434,7 +434,7 @@ configure (pkg_descr0, pbi) cfg = do
 
     let pseudoTopPkg = emptyInstalledPackageInfo {
             Installed.installedUnitId =
-               mkUnitId (display (packageId pkg_descr)),
+               mkLegacyUnitId (packageId pkg_descr),
             Installed.sourcePackageId = packageId pkg_descr,
             Installed.depends =
               map Installed.installedUnitId installDeps
@@ -737,10 +737,9 @@ getInternalPackages pkg_descr0 =
         internalPackage = emptyInstalledPackageInfo {
             --TODO: should use a per-compiler method to map the source
             --      package ID into an installed package id we can use
-            --      for the internal package set. The open-codes use of
-            --      mkUnitId here is a hack.
-            Installed.installedUnitId =
-               mkUnitId $ display $ pid,
+            --      for the internal package set. The use of
+            --      mkLegacyUnitId here is a hack.
+            Installed.installedUnitId = mkLegacyUnitId pid,
             Installed.sourcePackageId = pid
           }
     in PackageIndex.fromList [internalPackage]

Cabal/Distribution/Simple/GHC/IPI642.hs

@@ -61,16 +61,13 @@ data InstalledPackageInfo = InstalledPackageInfo {
   }
   deriving Read
 
-mkUnitId :: Current.PackageIdentifier -> Current.UnitId
-mkUnitId = Current.mkUnitId . display
-
 toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo
 toCurrent ipi@InstalledPackageInfo{} =
   let pid = convertPackageId (package ipi)
       mkExposedModule m = Current.ExposedModule m Nothing
   in Current.InstalledPackageInfo {
     Current.sourcePackageId    = pid,
-    Current.installedUnitId    = mkUnitId pid,
+    Current.installedUnitId    = Current.mkLegacyUnitId pid,
     Current.compatPackageKey   = "",
     Current.abiHash            = Current.AbiHash "", -- bogus but old GHCs don't care.
     Current.license            = convertLicense (license ipi),
@@ -95,7 +92,7 @@ toCurrent ipi@InstalledPackageInfo{} =
     Current.extraGHCiLibraries = extraGHCiLibraries ipi,
     Current.includeDirs        = includeDirs ipi,
     Current.includes           = includes ipi,
-    Current.depends            = map (mkUnitId.convertPackageId) (depends ipi),
+    Current.depends            = map (Current.mkLegacyUnitId . convertPackageId) (depends ipi),
     Current.ccOptions          = ccOptions ipi,
     Current.ldOptions          = ldOptions ipi,
     Current.frameworkDirs      = frameworkDirs ipi,

Cabal/Distribution/Simple/Haddock.hs

@@ -623,7 +623,9 @@ haddockPackageFlags lbi clbi htmlTemplate = do
 haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
 haddockTemplateEnv lbi pkg_id =
   (PrefixVar, prefix (installDirTemplates lbi))
-  : initialPathTemplateEnv pkg_id (mkUnitId (display pkg_id)) (compilerInfo (compiler lbi))
+  -- We want the legacy unit ID here, because it gives us nice paths
+  -- (Haddock people don't care about the dependencies)
+  : initialPathTemplateEnv pkg_id (mkLegacyUnitId pkg_id) (compilerInfo (compiler lbi))
   (hostPlatform lbi)
 
 -- ------------------------------------------------------------------------------

Cabal/Distribution/Simple/JHC.hs

@@ -99,7 +99,7 @@ getInstalledPackages verbosity _packageDBs conf = do
    return $
       PackageIndex.fromList $
       map (\p -> emptyInstalledPackageInfo {
-                    InstalledPackageInfo.installedUnitId = mkUnitId (display p),
+                    InstalledPackageInfo.installedUnitId = mkLegacyUnitId p,
                     InstalledPackageInfo.sourcePackageId = p
                  }) $
       concatMap parseLine $

Cabal/Distribution/Simple/LocalBuildInfo.hs

@@ -152,7 +152,7 @@ localComponentId lbi
 -- the package ID.
 localUnitId :: LocalBuildInfo -> UnitId
 localUnitId lbi =
-    foldr go (mkUnitId (display (package (localPkgDescr lbi)))) (componentsConfigs lbi)
+    foldr go (mkLegacyUnitId (package (localPkgDescr lbi))) (componentsConfigs lbi)
   where go (_, clbi, _) old_uid = case clbi of
             LibComponentLocalBuildInfo { componentUnitId = uid } -> uid
             _ -> old_uid

Cabal/Distribution/Simple/Program/HcPkg.hs

@@ -310,9 +310,7 @@ setUnitId pkginfo@InstalledPackageInfo {
                         sourcePackageId = pkgid
                       }
                     = pkginfo {
-                        --TODO use a proper named function for the conversion
-                        -- from source package id to installed package id
-                        installedUnitId = mkUnitId (display pkgid)
+                        installedUnitId = mkLegacyUnitId pkgid
                       }
 setUnitId pkginfo = pkginfo
 

Cabal/Distribution/Simple/UHC.hs

@@ -157,8 +157,8 @@ parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x))
 -- | Create a trivial package info from a directory name.
 mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
 mkInstalledPackageInfo p = emptyInstalledPackageInfo
-  { installedUnitId = mkUnitId (display p),
-    sourcePackageId     = p }
+  { installedUnitId = mkLegacyUnitId p,
+    sourcePackageId = p }
 
 
 -- -----------------------------------------------------------------------------