Commit 6cc46998 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

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

Support multiple instances of package ID in database with different deps
parents 47984faa 2b50d0a7
......@@ -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})
......
......@@ -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
-- ------------------------------------------------------------
......
......@@ -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)]
......@@ -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
......
......@@ -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 =
......
......@@ -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 {
......
......@@ -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 {
......
......@@ -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,
......
......@@ -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,
......
......@@ -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)
-- ------------------------------------------------------------------------------
......
......@@ -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