Merge pull request #2002 from ezyang/ezyang-pkg-key

Support multiple instances of package ID in database with different deps

Cabal/Distribution/InstalledPackageInfo.hs

@@ -77,7 +77,7 @@ import Distribution.License     ( License(..) )
 import Distribution.Package
          ( PackageName(..), PackageIdentifier(..)
          , PackageId, InstalledPackageId(..)
-         , packageName, packageVersion )
+         , packageName, packageVersion, PackageKey(..) )
 import qualified Distribution.Package as Package
          ( Package(..) )
 import Distribution.ModuleName
@@ -98,6 +98,7 @@ data InstalledPackageInfo_ m
         -- these parts are exactly the same as PackageDescription
         installedPackageId :: InstalledPackageId,
         sourcePackageId    :: PackageId,
+        packageKey         :: PackageKey,
         license           :: License,
         copyright         :: String,
         maintainer        :: String,
@@ -142,6 +143,8 @@ emptyInstalledPackageInfo
    = InstalledPackageInfo {
         installedPackageId = InstalledPackageId "",
         sourcePackageId    = PackageIdentifier (PackageName "") noVersion,
+        packageKey         = OldPackageKey (PackageIdentifier
+                                               (PackageName "") noVersion),
         license           = AllRightsReserved,
         copyright         = "",
         maintainer        = "",
@@ -213,6 +216,9 @@ basicFieldDescrs =
  , simpleField "id"
                            disp                   parse
                            installedPackageId     (\ipid pkg -> pkg{installedPackageId=ipid})
+ , simpleField "key"
+                           disp                   parse
+                           packageKey             (\ipid pkg -> pkg{packageKey=ipid})
  , simpleField "license"
                            disp                   parseLicenseQ
                            license                (\l pkg -> pkg{license=l})

Cabal/Distribution/Package.hs

@@ -22,6 +22,10 @@ module Distribution.Package (
         -- * Installed package identifiers
         InstalledPackageId(..),
 
+        -- * Package keys (used for linker symbols)
+        PackageKey(..),
+        mkPackageKey,
+
         -- * Package source dependencies
         Dependency(..),
         thisPackageVersion,
@@ -43,12 +47,16 @@ import Distribution.Compat.ReadP ((<++))
 import qualified Text.PrettyPrint as Disp
 import Text.PrettyPrint ((<>), (<+>), text)
 import Control.DeepSeq (NFData(..))
-import qualified Data.Char as Char ( isDigit, isAlphaNum )
-import Data.List ( intercalate )
+import qualified Data.Char as Char
+    ( isDigit, isAlphaNum, isUpper, isLower, ord, chr )
+import Data.List ( intercalate, sort, foldl' )
 import Data.Data ( Data )
 import Data.Typeable ( Typeable )
+import GHC.Fingerprint ( Fingerprint(..), fingerprintString )
+import Data.Word ( Word64 )
+import Numeric ( showIntAtBase )
 
-newtype PackageName = PackageName String
+newtype PackageName = PackageName { unPackageName :: String }
     deriving (Read, Show, Eq, Ord, Typeable, Data)
 
 instance Text PackageName where
@@ -107,6 +115,114 @@ instance Text InstalledPackageId where
   parse = InstalledPackageId `fmap` Parse.munch1 abi_char
    where abi_char c = Char.isAlphaNum c || c `elem` ":-_."
 
+-- ------------------------------------------------------------
+-- * Package Keys
+-- ------------------------------------------------------------
+
+-- | A 'PackageKey' is the notion of "package ID" which is visible to the
+-- compiler. Why is this not a 'PackageId'? The 'PackageId' is a user-visible
+-- concept written explicity in Cabal files; on the other hand, a 'PackageKey'
+-- may contain, for example, information about the transitive dependency
+-- tree of a package.  Why is this not an 'InstalledPackageId'?  A 'PackageKey'
+-- affects the ABI because it is used for linker symbols; however, an
+-- 'InstalledPackageId' can be used to distinguish two ABI-compatible versions
+-- of a library.
+data PackageKey
+    -- | Modern package key which is a hash of the PackageId and the transitive
+    -- dependency key.  Manually inline it here so we can get the instances
+    -- we need.  Also contains a short informative string
+    = PackageKey !String {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
+    -- | Old-style package key which is just a 'PackageId'.  Required because
+    -- old versions of GHC assume that the 'sourcePackageId' recorded for an
+    -- installed package coincides with the package key it was compiled with.
+    | OldPackageKey !PackageId
+    deriving (Read, Show, Eq, Ord, Typeable, Data)
+
+-- | Convenience function which converts a fingerprint into a new-style package
+-- key.
+fingerprintPackageKey :: String -> Fingerprint -> PackageKey
+fingerprintPackageKey s (Fingerprint a b) = PackageKey s a b
+
+-- | Generates a 'PackageKey' from a 'PackageId', sorted package keys of the
+-- immediate dependencies.
+mkPackageKey :: Bool -- are modern style package keys supported?
+             -> PackageId
+             -> [PackageKey] -- dependencies
+             -> PackageKey
+mkPackageKey True pid deps = fingerprintPackageKey stubName
+                           . fingerprintString
+                           . ((show pid ++ "\n") ++)
+                           $ show (sort deps)
+  where stubName = take 5 (filter (/= '-') (unPackageName (pkgName pid)))
+mkPackageKey False pid _ = OldPackageKey pid
+
+-- The base-62 code is based off of 'locators'
+-- ((c) Operational Dynamics Consulting, BSD3 licensed)
+
+-- Note: Instead of base-62 encoding a single 128-bit integer
+-- (ceil(21.49) characters), we'll base-62 a pair of 64-bit integers
+-- (2 * ceil(10.75) characters).  Luckily for us, it's the same number of
+-- characters!  In the long term, this should go in GHC.Fingerprint,
+-- but not now...
+
+-- | Size of a 64-bit word when written as a base-62 string
+word64Base62Len :: Int
+word64Base62Len = 11
+
+-- | Converts a 64-bit word into a base-62 string
+toBase62 :: Word64 -> String
+toBase62 w = pad ++ str
+  where
+    pad = replicate len '0'
+    len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)
+    str = showIntAtBase 62 represent w ""
+    represent :: Int -> Char
+    represent x
+        | x < 10 = Char.chr (48 + x)
+        | x < 36 = Char.chr (65 + x - 10)
+        | x < 62 = Char.chr (97 + x - 36)
+        | otherwise = error ("represent (base 62): impossible!")
+
+-- | Parses a base-62 string into a 64-bit word
+fromBase62 :: String -> Word64
+fromBase62 ss = foldl' multiply 0 ss
+  where
+    value :: Char -> Int
+    value c
+        | Char.isDigit c = Char.ord c - 48
+        | Char.isUpper c = Char.ord c - 65 + 10
+        | Char.isLower c = Char.ord c - 97 + 36
+        | otherwise = error ("value (base 62): impossible!")
+
+    multiply :: Word64 -> Char -> Word64
+    multiply acc c = acc * 62 + (fromIntegral $ value c)
+
+-- | Parses a base-62 string into a fingerprint.
+readBase62Fingerprint :: String -> Fingerprint
+readBase62Fingerprint s = Fingerprint w1 w2
+ where (s1,s2) = splitAt word64Base62Len s
+       w1 = fromBase62 s1
+       w2 = fromBase62 (take word64Base62Len s2)
+
+instance Text PackageKey where
+  disp (PackageKey prefix w1 w2) = Disp.text prefix <> Disp.char '_'
+                        <> Disp.text (toBase62 w1) <> Disp.text (toBase62 w2)
+  disp (OldPackageKey pid) = disp pid
+
+  parse = parseNew <++ parseOld
+    where parseNew = do
+            prefix <- Parse.munch1 (\c -> Char.isAlphaNum c || c `elem` "-")
+            _ <- Parse.char '_' -- if we use '-' it's ambiguous
+            fmap (fingerprintPackageKey prefix . readBase62Fingerprint)
+                . Parse.count (word64Base62Len * 2)
+                $ Parse.satisfy Char.isAlphaNum
+          parseOld = do pid <- parse
+                        return (OldPackageKey pid)
+
+instance NFData PackageKey where
+    rnf (PackageKey prefix _ _) = rnf prefix
+    rnf (OldPackageKey pid) = rnf pid
+
 -- ------------------------------------------------------------
 -- * Package source dependencies
 -- ------------------------------------------------------------

Cabal/Distribution/Simple/Bench.hs

@@ -123,6 +123,6 @@ benchOption pkg_descr lbi bm template =
     fromPathTemplate $ substPathTemplate env template
   where
     env = initialPathTemplateEnv
-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)
-          (LBI.hostPlatform lbi) ++
+          (PD.package pkg_descr) (LBI.pkgKey lbi)
+          (compilerId $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
           [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]

Cabal/Distribution/Simple/Build.hs

@@ -36,10 +36,10 @@ import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule
 
 import Distribution.Package
          ( Package(..), PackageName(..), PackageIdentifier(..)
-         , Dependency(..), thisPackageVersion )
+         , Dependency(..), thisPackageVersion, mkPackageKey )
 import Distribution.Simple.Compiler
          ( Compiler, CompilerFlavor(..), compilerFlavor
-         , PackageDB(..), PackageDBStack )
+         , PackageDB(..), PackageDBStack, packageKeySupported )
 import Distribution.PackageDescription
          ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)
          , TestSuite(..), TestSuiteInterface(..), Benchmark(..)
@@ -55,7 +55,7 @@ import Distribution.Simple.BuildTarget
 import Distribution.Simple.PreProcess
          ( preprocessComponent, PPSuffixHandler )
 import Distribution.Simple.LocalBuildInfo
-         ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)
+         ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms, pkgKey)
          , Component(..), componentName, getComponent, componentBuildInfo
          , ComponentLocalBuildInfo(..), pkgEnabledComponents
          , withComponentsInBuildOrder, componentsInBuildOrder
@@ -226,7 +226,7 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
     buildExe verbosity numJobs pkg_descr lbi exe clbi
 
 
-buildComponent verbosity numJobs pkg_descr lbi suffixes
+buildComponent verbosity numJobs pkg_descr lbi0 suffixes
                comp@(CTest
                  test@TestSuite { testInterface = TestSuiteLibV09{} })
                clbi -- This ComponentLocalBuildInfo corresponds to a detailed
@@ -236,8 +236,8 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
                     -- built.
                distPref = do
     pwd <- getCurrentDirectory
-    let (pkg, lib, libClbi, ipi, exe, exeClbi) =
-          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd
+    let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =
+          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
     info verbosity $ "Building test suite " ++ testName test ++ "..."
     buildLib verbosity numJobs pkg lbi lib libClbi
@@ -293,13 +293,13 @@ replComponent verbosity pkg_descr lbi suffixes
     replExe verbosity pkg_descr lbi exe clbi
 
 
-replComponent verbosity pkg_descr lbi suffixes
+replComponent verbosity pkg_descr lbi0 suffixes
                comp@(CTest
                  test@TestSuite { testInterface = TestSuiteLibV09{} })
                clbi distPref = do
     pwd <- getCurrentDirectory
-    let (pkg, lib, libClbi, _, _, _) =
-          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd
+    let (pkg, lib, libClbi, lbi, _, _, _) =
+          testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
     preprocessComponent pkg_descr comp lbi False verbosity suffixes
     replLib verbosity pkg lbi lib libClbi
 
@@ -339,19 +339,20 @@ testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"
 
 -- | Translate a lib-style 'TestSuite' component into a lib + exe for building
 testSuiteLibV09AsLibAndExe :: PackageDescription
-                           -> LocalBuildInfo
                            -> TestSuite
                            -> ComponentLocalBuildInfo
+                           -> LocalBuildInfo
                            -> FilePath
                            -> FilePath
                            -> (PackageDescription,
                                Library, ComponentLocalBuildInfo,
+                               LocalBuildInfo,
                                IPI.InstalledPackageInfo_ ModuleName,
                                Executable, ComponentLocalBuildInfo)
-testSuiteLibV09AsLibAndExe pkg_descr lbi
+testSuiteLibV09AsLibAndExe pkg_descr
                      test@TestSuite { testInterface = TestSuiteLibV09 _ m }
-                     clbi distPref pwd =
-    (pkg, lib, libClbi, ipi, exe, exeClbi)
+                     clbi lbi distPref pwd =
+    (pkg, lib, libClbi, lbi', ipi, exe, exeClbi)
   where
     bi  = testBuildInfo test
     lib = Library {
@@ -373,6 +374,14 @@ testSuiteLibV09AsLibAndExe pkg_descr lbi
           , testSuites   = []
           , library      = Just lib
           }
+    -- Hack to make the library compile with the right package key.
+    -- Probably the "right" way to do this is move this information to
+    -- the ComponentLocalBuildInfo, but it seems odd that a single package
+    -- can define multiple actual packages.
+    lbi' = lbi {
+        pkgKey = mkPackageKey (packageKeySupported (compiler lbi))
+                              (package pkg) []
+    }
     ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi libClbi) {
             IPI.installedPackageId = inplacePackageId $ packageId ipi
           }
@@ -397,7 +406,7 @@ testSuiteLibV09AsLibAndExe pkg_descr lbi
                                         in name == "Cabal" || name == "base")
                             (componentPackageDeps clbi))
               }
-testSuiteLibV09AsLibAndExe _ _ TestSuite{} _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
+testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
 
 
 -- | Translate a exe-style 'Benchmark' component into an exe for building

Cabal/Distribution/Simple/Compiler.hs

@@ -42,7 +42,8 @@ module Distribution.Simple.Compiler (
         extensionsToFlags,
         unsupportedExtensions,
         parmakeSupported,
-        reexportedModulesSupported
+        reexportedModulesSupported,
+        packageKeySupported
   ) where
 
 import Distribution.Compiler
@@ -196,6 +197,10 @@ parmakeSupported = ghcSupported "Support parallel --make"
 reexportedModulesSupported :: Compiler -> Bool
 reexportedModulesSupported = ghcSupported "Support reexported-modules"
 
+-- | Does this compiler support package keys?
+packageKeySupported :: Compiler -> Bool
+packageKeySupported = ghcSupported "Uses package keys"
+
 -- | Utility function for GHC only features
 ghcSupported :: String -> Compiler -> Bool
 ghcSupported key comp =

Cabal/Distribution/Simple/Configure.hs

@@ -45,15 +45,17 @@ module Distribution.Simple.Configure (configure,
 import Distribution.Compiler
     ( CompilerId(..) )
 import Distribution.Simple.Compiler
-    ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion
+    ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion
     , showCompilerId, unsupportedLanguages, unsupportedExtensions
-    , PackageDB(..), PackageDBStack, reexportedModulesSupported )
+    , PackageDB(..), PackageDBStack, reexportedModulesSupported
+    , packageKeySupported )
 import Distribution.Simple.PreProcess ( platformDefines )
 import Distribution.Package
     ( PackageName(PackageName), PackageIdentifier(..), PackageId
     , packageName, packageVersion, Package(..)
     , Dependency(Dependency), simplifyDependency
-    , InstalledPackageId(..), thisPackageVersion )
+    , InstalledPackageId(..), thisPackageVersion
+    , mkPackageKey, PackageKey(..) )
 import Distribution.InstalledPackageInfo as Installed
     ( InstalledPackageInfo, InstalledPackageInfo_(..)
     , emptyInstalledPackageInfo )
@@ -457,10 +459,17 @@ configure (pkg_descr0, pbi) cfg
                          | (name, uses) <- inconsistencies
                          , (pkg, ver) <- uses ]
 
+        -- Calculate the package key.  We're going to store it in LocalBuildInfo
+        -- canonically, but ComponentsLocalBuildInfo also needs to know about it
+        -- XXX Do we need the internal deps?
+        let pkg_key = mkPackageKey (packageKeySupported comp)
+                                   (package pkg_descr)
+                                   (map packageKey externalPkgDeps)
+
         -- internal component graph
         buildComponents <-
           case mkComponentsLocalBuildInfo pkg_descr
-                 internalPkgDeps externalPkgDeps of
+                 internalPkgDeps externalPkgDeps pkg_key of
             Left  componentCycle -> reportComponentCycle componentCycle
             Right components     -> return components
 
@@ -542,6 +551,7 @@ configure (pkg_descr0, pbi) cfg
                     installedPkgs       = packageDependsIndex,
                     pkgDescrFile        = Nothing,
                     localPkgDescr       = pkg_descr',
+                    pkgKey              = pkg_key,
                     withPrograms        = programsConfig''',
                     withVanillaLib      = fromFlag $ configVanillaLib cfg,
                     withProfLib         = fromFlag $ configProfLib cfg,
@@ -1017,10 +1027,11 @@ configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx
 
 mkComponentsLocalBuildInfo :: PackageDescription
                            -> [PackageId] -> [InstalledPackageInfo]
+                           -> PackageKey
                            -> Either [ComponentName]
                                      [(ComponentName,
                                        ComponentLocalBuildInfo, [ComponentName])]
-mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =
+mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps pkg_key =
     let graph = [ (c, componentName c, componentDeps c)
                 | c <- pkgEnabledComponents pkg_descr ]
      in case checkComponentsCyclic graph of
@@ -1052,7 +1063,7 @@ mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =
         LibComponentLocalBuildInfo {
           componentPackageDeps = cpds,
           componentLibraries = [LibraryName
-                                ("HS" ++ display (package pkg_descr))]
+                                ("HS" ++ display pkg_key)]
         }
       CExe _ ->
         ExeComponentLocalBuildInfo {

Cabal/Distribution/Simple/GHC.hs

@@ -66,7 +66,7 @@ import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )
 import Distribution.Simple.BuildPaths
 import Distribution.Simple.Utils
 import Distribution.Package
-         ( Package(..), PackageName(..) )
+         ( PackageName(..) )
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.Simple.Program
          ( Program(..), ConfiguredProgram(..), ProgramConfiguration
@@ -679,7 +679,6 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
 
   let libTargetDir = buildDir lbi
       numJobs = fromMaybe 1 $ fromFlagOrDefault Nothing numJobsFlag
-      pkgid = packageId pkg_descr
       whenVanillaLib forceVanilla =
         when (forceVanilla || withVanillaLib lbi)
       whenProfLib = when (withProfLib lbi)
@@ -712,7 +711,7 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
       vanillaOpts = baseOpts `mappend` mempty {
                       ghcOptMode         = toFlag GhcModeMake,
                       ghcOptNumJobs      = toFlag numJobs,
-                      ghcOptPackageName  = toFlag pkgid,
+                      ghcOptPackageKey   = toFlag (pkgKey lbi),
                       ghcOptInputModules = libModules lib
                     }
 
@@ -874,7 +873,7 @@ buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do
                                                && ghcVersion < Version [7,8] [])
                                             then toFlag sharedLibInstallPath
                                             else mempty,
-                ghcOptPackageName        = toFlag pkgid,
+                ghcOptPackageKey         = toFlag (pkgKey lbi),
                 ghcOptNoAutoLinkPackages = toFlag True,
                 ghcOptPackageDBs         = withPackageDB lbi,
                 ghcOptPackages           = componentPackageDeps clbi,
@@ -1124,7 +1123,7 @@ getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs
 --
 libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
            -> Library -> ComponentLocalBuildInfo -> IO String
-libAbiHash verbosity pkg_descr lbi lib clbi = do
+libAbiHash verbosity _pkg_descr lbi lib clbi = do
   libBi <- hackThreadedFlag verbosity
              (compiler lbi) (withProfLib lbi) (libBuildInfo lib)
   let
@@ -1133,7 +1132,7 @@ libAbiHash verbosity pkg_descr lbi lib clbi = do
         (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
         `mappend` mempty {
           ghcOptMode         = toFlag GhcModeAbiHash,
-          ghcOptPackageName  = toFlag (packageId pkg_descr),
+          ghcOptPackageKey   = toFlag (pkgKey lbi),
           ghcOptInputModules = exposedModules lib
         }
       sharedArgs = vanillaArgs `mappend` mempty {

Cabal/Distribution/Simple/GHC/IPI641.hs

@@ -66,9 +66,11 @@ mkInstalledPackageId = Current.InstalledPackageId . display
 
 toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo
 toCurrent ipi@InstalledPackageInfo{} =
-  Current.InstalledPackageInfo {
+  let pid = convertPackageId (package ipi)
+  in Current.InstalledPackageInfo {
     Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),
-    Current.sourcePackageId    = convertPackageId (package ipi),
+    Current.sourcePackageId    = pid,
+    Current.packageKey         = Current.OldPackageKey pid,
     Current.license            = convertLicense (license ipi),
     Current.copyright          = copyright ipi,
     Current.maintainer         = maintainer ipi,

Cabal/Distribution/Simple/GHC/IPI642.hs

@@ -101,9 +101,11 @@ convertLicense OtherLicense = Current.OtherLicense
 
 toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo
 toCurrent ipi@InstalledPackageInfo{} =
-  Current.InstalledPackageInfo {
+  let pid = convertPackageId (package ipi)
+  in Current.InstalledPackageInfo {
     Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),
-    Current.sourcePackageId    = convertPackageId (package ipi),
+    Current.sourcePackageId    = pid,
+    Current.packageKey         = Current.OldPackageKey pid,
     Current.license            = convertLicense (license ipi),
     Current.copyright          = copyright ipi,
     Current.maintainer         = maintainer ipi,

Cabal/Distribution/Simple/Haddock.hs

@@ -534,7 +534,7 @@ haddockPackageFlags lbi clbi htmlTemplate = do
 haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
 haddockTemplateEnv lbi pkg_id =
   (PrefixVar, prefix (installDirTemplates lbi))
-  : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))
+  : initialPathTemplateEnv pkg_id (pkgKey lbi) (compilerId (compiler lbi))
   (hostPlatform lbi)
 
 -- ------------------------------------------------------------------------------

Cabal/Distribution/Simple/InstallDirs.hs

@@ -49,7 +49,7 @@ import System.FilePath ((</>), isPathSeparator, pathSeparator)
 import System.FilePath (dropDrive)
 
 import Distribution.Package
-         ( PackageIdentifier, packageName, packageVersion )
+         ( PackageIdentifier, PackageKey, packageName, packageVersion )
 import Distribution.System
          ( OS(..), buildOS, Platform(..) )
 import Distribution.Compiler
@@ -177,7 +177,7 @@ appendSubdirs append dirs = dirs {
 -- users to be able to configure @--libdir=\/usr\/lib64@ for example but
 -- because by default we want to support installing multiple versions of
 -- packages and building the same package for multiple compilers we append the
--- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@.
+-- libsubdir to get: @\/usr\/lib64\/$pkgkey\/$compiler@.
 --
 -- An additional complication is the need to support relocatable packages on
 -- systems which support such things, like Windows.
@@ -211,10 +211,10 @@ defaultInstallDirs comp userInstall _hasLibs = do
            JHC    -> "$compiler"
            LHC    -> "$compiler"
            UHC    -> "$pkgid"
-           _other -> "$arch-$os-$compiler" </> "$pkgid",
+           _other -> "$arch-$os-$compiler" </> "$pkgkey",
       dynlibdir    = "$libdir",
       libexecdir   = case buildOS of
-        Windows   -> "$prefix" </> "$pkgid"
+        Windows   -> "$prefix" </> "$pkgkey"
         _other    -> "$prefix" </> "libexec",
       progdir      = "$libdir" </> "hugs" </> "programs",
       includedir   = "$libdir" </> "$libsubdir" </> "include",
@@ -283,10 +283,14 @@ substituteInstallDirTemplates env dirs = dirs'
 -- | Convert from abstract install directories to actual absolute ones by
 -- substituting for all the variables in the abstract paths, to get real
 -- absolute path.
-absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest -> Platform
+absoluteInstallDirs :: PackageIdentifier
+                    -> PackageKey
+                    -> CompilerId
+                    -> CopyDest
+                    -> Platform
                     -> InstallDirs PathTemplate
                     -> InstallDirs FilePath
-absoluteInstallDirs pkgId compilerId copydest platform dirs =
+absoluteInstallDirs pkgId pkg_key compilerId copydest platform dirs =
     (case copydest of
        CopyTo destdir -> fmap ((destdir </>) . dropDrive)
        _              -> id)
@@ -294,7 +298,7 @@ absoluteInstallDirs pkgId compilerId copydest platform dirs =
   . fmap fromPathTemplate
   $ substituteInstallDirTemplates env dirs
   where
-    env = initialPathTemplateEnv pkgId compilerId platform
+    env = initialPathTemplateEnv pkgId pkg_key compilerId platform
 
 
 -- |The location prefix for the /copy/ command.
@@ -309,10 +313,13 @@ data CopyDest
 -- prevents us from making a relocatable package (also known as a \"prefix
 -- independent\" package).
 --
-prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId -> Platform
+prefixRelativeInstallDirs :: PackageIdentifier
+                          -> PackageKey
+                          -> CompilerId
+                          -> Platform
                           -> InstallDirTemplates
                           -> InstallDirs (Maybe FilePath)
-prefixRelativeInstallDirs pkgId compilerId platform dirs =
+prefixRelativeInstallDirs pkgId pkg_key compilerId platform dirs =
     fmap relative
   . appendSubdirs combinePathTemplate
   $ -- substitute the path template into each other, except that we map
@@ -322,7 +329,7 @@ prefixRelativeInstallDirs pkgId compilerId platform dirs =
       prefix = PathTemplate [Variable PrefixVar]
     }
   where
-    env = initialPathTemplateEnv pkgId compilerId platform
+    env = initialPathTemplateEnv pkgId pkg_key compilerId platform
 
     -- If it starts with $prefix then it's relative and produce the relative
     -- path by stripping off $prefix/ or $prefix
@@ -358,6 +365,7 @@ data PathTemplateVariable =
      | PkgNameVar    -- ^ The @$pkg@ package name path variable
      | PkgVerVar     -- ^ The @$version@ package version path variable
      | PkgIdVar      -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@
+     | PkgKeyVar     -- ^ The @$pkgkey@ package key path variable
      | CompilerVar   -- ^ The compiler name and version, eg @ghc-6.6.1@
      | OSVar         -- ^ The operating system name, eg @windows@ or @linux@
      | ArchVar       -- ^ The CPU architecture name, eg @i386@ or @x86_64@
@@ -395,17 +403,21 @@ substPathTemplate environment (PathTemplate template) =
                   Nothing                        -> [component]
 
 -- | The initial environment has all the static stuff but no paths
-initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> Platform
+initialPathTemplateEnv :: PackageIdentifier
+                       -> PackageKey
+                       -> CompilerId
+                       -> Platform
                        -> PathTemplateEnv
-initialPathTemplateEnv pkgId compilerId platform =
-     packageTemplateEnv  pkgId
+initialPathTemplateEnv pkgId pkg_key compilerId platform =
+     packageTemplateEnv  pkgId pkg_key
   ++ compilerTemplateEnv compilerId
   ++ platformTemplateEnv platform
 
-packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv
-packageTemplateEnv pkgId =
+packageTemplateEnv :: PackageIdentifier -> PackageKey -> PathTemplateEnv
+packageTemplateEnv pkgId pkg_key =
   [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])
   ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])
+  ,(PkgKeyVar,   PathTemplate [Ordinary $ display pkg_key])
   ,(PkgIdVar,    PathTemplate [Ordinary $ display pkgId])
   ]
 
@@ -444,6 +456,7 @@ installDirsTemplateEnv dirs =
 
 instance Show PathTemplateVariable where
   show PrefixVar     = "prefix"
+  show PkgKeyVar     = "pkgkey"
   show BindirVar     = "bindir"
   show LibdirVar     = "libdir"
   show LibsubdirVar  = "libsubdir"
@@ -468,6 +481,7 @@ instance Read PathTemplateVariable where
     [ (var, drop (length varStr) s)
     | (varStr, var) <- vars
     , varStr `isPrefixOf` s ]
+    -- NB: order matters! Longer strings first
     where vars = [("prefix",     PrefixVar)
                  ,("bindir",     BindirVar)
                  ,("libdir",     LibdirVar)
@@ -477,6 +491,7 @@ instance Read PathTemplateVariable where