Commit 18fcd9c1 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Properly assign component ID/build dir for LibV09 test libraries



Cabal's LibV09 support has always been a bit skeevy.  The general
idea was that a detailed-0.9 test-suite is built as a library
and an Cabal-provided stub executable.  In particular, the test suite
library must be installed to the installed package database so that the
executable can be compiled.

Old versions of Cabal did something very skeevy here:  they installed
the test library as a "package", with the same package name as
the "test-suite" stanza; furthermore, they built the products
into the same directory as the library proper.

Consequently, a lot of bad things could happen (both of which I've
added tests for):

    1. If the name of the test suite and the name of some other
    package coincide (and have the same version), they will clobber
    each other.  In GHC 7.8 and earlier, this just flat out
    kills the build, because it will shadow.  There's an explicit
    test to make sure test suites don't conflict with the package
    name, but you can get unlucky.

    2. The test suite library is built into the same directory
    as the main library, which means that if the test library
    implements the same module name as something in the main
    library it will clobber the interface file and badness
    will ensue.

This patchset fixes both of these issues, by (1) giving internal
test libraries proper names which are guaranteed to be unique
up to Cabal's dependency resolution, and (2) building the test
suite library into a separate directory.

In doing so, it also lays the groundwork for other types of
internal libraries, e.g. #269, as well as extra (invisible)
libraries which we may install.

For GHC 7.8 and earlier, we follow the reserved namespace
convention as per #3017.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 98cd8ca8
...@@ -82,6 +82,10 @@ extra-source-files: ...@@ -82,6 +82,10 @@ extra-source-files:
tests/PackageTests/CMain/my.cabal tests/PackageTests/CMain/my.cabal
tests/PackageTests/DeterministicAr/Lib.hs tests/PackageTests/DeterministicAr/Lib.hs
tests/PackageTests/DeterministicAr/my.cabal tests/PackageTests/DeterministicAr/my.cabal
tests/PackageTests/DuplicateModuleName/DuplicateModuleName.cabal
tests/PackageTests/DuplicateModuleName/src/Foo.hs
tests/PackageTests/DuplicateModuleName/tests/Foo.hs
tests/PackageTests/DuplicateModuleName/tests2/Foo.hs
tests/PackageTests/EmptyLib/empty/empty.cabal tests/PackageTests/EmptyLib/empty/empty.cabal
tests/PackageTests/Haddock/CPP.hs tests/PackageTests/Haddock/CPP.hs
tests/PackageTests/Haddock/Literate.lhs tests/PackageTests/Haddock/Literate.lhs
...@@ -115,6 +119,11 @@ extra-source-files: ...@@ -115,6 +119,11 @@ extra-source-files:
tests/PackageTests/TemplateHaskell/vanilla/Lib.hs tests/PackageTests/TemplateHaskell/vanilla/Lib.hs
tests/PackageTests/TemplateHaskell/vanilla/TH.hs tests/PackageTests/TemplateHaskell/vanilla/TH.hs
tests/PackageTests/TemplateHaskell/vanilla/my.cabal tests/PackageTests/TemplateHaskell/vanilla/my.cabal
tests/PackageTests/TestNameCollision/child/Child.hs
tests/PackageTests/TestNameCollision/child/child.cabal
tests/PackageTests/TestNameCollision/child/tests/Test.hs
tests/PackageTests/TestNameCollision/parent/Parent.hs
tests/PackageTests/TestNameCollision/parent/parent.cabal
tests/PackageTests/TestOptions/TestOptions.cabal tests/PackageTests/TestOptions/TestOptions.cabal
tests/PackageTests/TestOptions/test-TestOptions.hs tests/PackageTests/TestOptions/test-TestOptions.hs
tests/PackageTests/TestStanza/my.cabal tests/PackageTests/TestStanza/my.cabal
......
...@@ -297,14 +297,6 @@ checkTestSuite pkg test = ...@@ -297,14 +297,6 @@ checkTestSuite pkg test =
PackageDistInexcusable $ PackageDistInexcusable $
"The package uses a C/C++/obj-C source file for the 'main-is' field. " "The package uses a C/C++/obj-C source file for the 'main-is' field. "
++ "To use this feature you must specify 'cabal-version: >= 1.18'." ++ "To use this feature you must specify 'cabal-version: >= 1.18'."
-- Test suites might be built as (internal) libraries named after
-- the test suite and thus their names must not clash with the
-- name of the package.
, check libNameClash $
PackageBuildImpossible $
"The test suite " ++ testName test
++ " has the same name as the package."
] ]
where where
moduleDuplicates = dups $ testModules test moduleDuplicates = dups $ testModules test
...@@ -317,13 +309,8 @@ checkTestSuite pkg test = ...@@ -317,13 +309,8 @@ checkTestSuite pkg test =
TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
_ -> False _ -> False
libNameClash = testName test `elem` [ libName
| _lib <- maybeToList (library pkg)
, let PackageName libName =
pkgName (package pkg) ]
checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck] checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]
checkBenchmark pkg bm = checkBenchmark _pkg bm =
catMaybes [ catMaybes [
case benchmarkInterface bm of case benchmarkInterface bm of
...@@ -349,12 +336,6 @@ checkBenchmark pkg bm = ...@@ -349,12 +336,6 @@ checkBenchmark pkg bm =
PackageBuildImpossible $ PackageBuildImpossible $
"The 'main-is' field must specify a '.hs' or '.lhs' file " "The 'main-is' field must specify a '.hs' or '.lhs' file "
++ "(even if it is generated by a preprocessor)." ++ "(even if it is generated by a preprocessor)."
-- See comment for similar check on test suites.
, check libNameClash $
PackageBuildImpossible $
"The benchmark " ++ benchmarkName bm
++ " has the same name as the package."
] ]
where where
moduleDuplicates = dups $ benchmarkModules bm moduleDuplicates = dups $ benchmarkModules bm
...@@ -363,11 +344,6 @@ checkBenchmark pkg bm = ...@@ -363,11 +344,6 @@ checkBenchmark pkg bm =
BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
_ -> False _ -> False
libNameClash = benchmarkName bm `elem` [ libName
| _lib <- maybeToList (library pkg)
, let PackageName libName =
pkgName (package pkg) ]
-- ------------------------------------------------------------ -- ------------------------------------------------------------
-- * Additional pure checks -- * Additional pure checks
-- ------------------------------------------------------------ -- ------------------------------------------------------------
......
...@@ -47,6 +47,7 @@ import Distribution.Simple.LocalBuildInfo ...@@ -47,6 +47,7 @@ import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Types import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Db import Distribution.Simple.Program.Db
import Distribution.Simple.BuildPaths import Distribution.Simple.BuildPaths
import Distribution.Simple.Configure
import Distribution.Simple.Register import Distribution.Simple.Register
import Distribution.Simple.Test.LibV09 import Distribution.Simple.Test.LibV09
import Distribution.Simple.Utils import Distribution.Simple.Utils
...@@ -225,7 +226,10 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes ...@@ -225,7 +226,10 @@ buildComponent verbosity numJobs pkg_descr lbi0 suffixes
extras <- preprocessExtras comp lbi extras <- preprocessExtras comp lbi
info verbosity $ "Building test suite " ++ testName test ++ "..." info verbosity $ "Building test suite " ++ testName test ++ "..."
buildLib verbosity numJobs pkg lbi lib libClbi buildLib verbosity numJobs pkg lbi lib libClbi
registerPackage verbosity (compiler lbi) (withPrograms lbi) False -- NB: need to enable multiple instances here, because on 7.10+
-- the package name is the same as the library, and we still
-- want the registration to go through.
registerPackage verbosity (compiler lbi) (withPrograms lbi) True
(withPackageDB lbi) ipi (withPackageDB lbi) ipi
let ebi = buildInfo exe let ebi = buildInfo exe
exe' = exe { buildInfo = addExtraCSources ebi extras } exe' = exe { buildInfo = addExtraCSources ebi extras }
...@@ -377,17 +381,22 @@ testSuiteLibV09AsLibAndExe pkg_descr ...@@ -377,17 +381,22 @@ testSuiteLibV09AsLibAndExe pkg_descr
libExposed = True, libExposed = True,
libBuildInfo = bi libBuildInfo = bi
} }
cid = computeComponentId (package pkg_descr)
(CTestName (testName test))
(map fst (componentPackageDeps clbi))
(flagAssignment lbi)
(pkg_name, compat_key) = computeCompatPackageKey
(compiler lbi) (package pkg_descr)
(CTestName (testName test)) cid
libClbi = LibComponentLocalBuildInfo libClbi = LibComponentLocalBuildInfo
{ componentPackageDeps = componentPackageDeps clbi { componentPackageDeps = componentPackageDeps clbi
, componentPackageRenaming = componentPackageRenaming clbi , componentPackageRenaming = componentPackageRenaming clbi
, componentId = ComponentId $ display (packageId pkg) , componentId = cid
, componentCompatPackageKey = ComponentId $ display (packageId pkg) , componentCompatPackageKey = compat_key
, componentExposedModules = [IPI.ExposedModule m Nothing Nothing] , componentExposedModules = [IPI.ExposedModule m Nothing Nothing]
} }
pkg = pkg_descr { pkg = pkg_descr {
package = (package pkg_descr) { package = (package pkg_descr) { pkgName = pkg_name }
pkgName = PackageName (testName test)
}
, buildDepends = targetBuildDepends $ testBuildInfo test , buildDepends = targetBuildDepends $ testBuildInfo test
, executables = [] , executables = []
, testSuites = [] , testSuites = []
...@@ -415,9 +424,7 @@ testSuiteLibV09AsLibAndExe pkg_descr ...@@ -415,9 +424,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
: (filter (\(_, x) -> let PackageName name = pkgName x : (filter (\(_, x) -> let PackageName name = pkgName x
in name == "Cabal" || name == "base") in name == "Cabal" || name == "base")
(componentPackageDeps clbi)), (componentPackageDeps clbi)),
componentPackageRenaming = componentPackageRenaming = Map.empty
Map.insert (packageName ipi) defaultRenaming
(componentPackageRenaming clbi)
} }
testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind" testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
...@@ -447,7 +454,7 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath ...@@ -447,7 +454,7 @@ createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
createInternalPackageDB verbosity lbi distPref = do createInternalPackageDB verbosity lbi distPref = do
existsAlready <- doesPackageDBExist dbPath existsAlready <- doesPackageDBExist dbPath
when existsAlready $ deletePackageDB dbPath when existsAlready $ deletePackageDB dbPath
createPackageDB verbosity (compiler lbi) (withPrograms lbi) True dbPath createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
return (SpecificPackageDB dbPath) return (SpecificPackageDB dbPath)
where where
dbPath = case compilerFlavor (compiler lbi) of dbPath = case compilerFlavor (compiler lbi) of
......
...@@ -35,6 +35,7 @@ module Distribution.Simple.Configure (configure, ...@@ -35,6 +35,7 @@ module Distribution.Simple.Configure (configure,
maybeGetPersistBuildConfig, maybeGetPersistBuildConfig,
findDistPref, findDistPrefOrDefault, findDistPref, findDistPrefOrDefault,
computeComponentId, computeComponentId,
computeCompatPackageKey,
localBuildInfoFile, localBuildInfoFile,
getInstalledPackages, getInstalledPackages,
getInstalledPackagesMonitorFiles, getInstalledPackagesMonitorFiles,
...@@ -86,7 +87,7 @@ import Control.Exception ...@@ -86,7 +87,7 @@ import Control.Exception
( Exception, evaluate, throw, throwIO, try ) ( Exception, evaluate, throw, throwIO, try )
import Control.Exception ( ErrorCall ) import Control.Exception ( ErrorCall )
import Control.Monad import Control.Monad
( liftM, when, unless, foldM, filterM ) ( liftM, when, unless, foldM, filterM, mplus )
import Distribution.Compat.Binary ( decodeOrFailIO, encode ) import Distribution.Compat.Binary ( decodeOrFailIO, encode )
import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) import GHC.Fingerprint ( Fingerprint(..), fingerprintString )
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
...@@ -107,7 +108,6 @@ import Data.Traversable ...@@ -107,7 +108,6 @@ import Data.Traversable
import Data.Typeable import Data.Typeable
import Data.Char ( chr, isAlphaNum ) import Data.Char ( chr, isAlphaNum )
import Numeric ( showIntAtBase ) import Numeric ( showIntAtBase )
import Data.Bits ( shift )
import System.Directory import System.Directory
( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )
import System.FilePath import System.FilePath
...@@ -360,11 +360,13 @@ configure (pkg_descr0, pbi) cfg = do ...@@ -360,11 +360,13 @@ configure (pkg_descr0, pbi) cfg = do
(configDependencies cfg) (configDependencies cfg)
installedPackageSet installedPackageSet
-- The resolved package description, that does not contain any -- pkg_descr: The resolved package description, that does not contain any
-- conditionals, because we have have an assignment for every -- conditionals, because we have have an assignment for
-- flag, either picking them ourselves using a simple naive -- every flag, either picking them ourselves using a
-- algorithm, or having them be passed to us by -- simple naive algorithm, or having them be passed to
-- 'configConfigurationsFlags') -- us by 'configConfigurationsFlags')
-- flags: The 'FlagAssignment' that the conditionals were
-- resolved with.
-- --
-- NB: Why doesn't finalizing a package also tell us what the -- NB: Why doesn't finalizing a package also tell us what the
-- dependencies are (e.g. when we run the naive algorithm, -- dependencies are (e.g. when we run the naive algorithm,
...@@ -373,7 +375,7 @@ configure (pkg_descr0, pbi) cfg = do ...@@ -373,7 +375,7 @@ configure (pkg_descr0, pbi) cfg = do
-- if the flags are all chosen for us, this step is a simple -- if the flags are all chosen for us, this step is a simple
-- matter of flattening according to that assignment. It's -- matter of flattening according to that assignment. It's
-- cleaner to then configure the dependencies afterwards. -- cleaner to then configure the dependencies afterwards.
pkg_descr (pkg_descr, flags)
<- configureFinalizedPackage verbosity cfg <- configureFinalizedPackage verbosity cfg
allConstraints allConstraints
(dependencySatisfiable (dependencySatisfiable
...@@ -597,6 +599,7 @@ configure (pkg_descr0, pbi) cfg = do ...@@ -597,6 +599,7 @@ configure (pkg_descr0, pbi) cfg = do
let lbi = LocalBuildInfo { let lbi = LocalBuildInfo {
configFlags = cfg', configFlags = cfg',
flagAssignment = flags,
extraConfigArgs = [], -- Currently configure does not extraConfigArgs = [], -- Currently configure does not
-- take extra args, but if it -- take extra args, but if it
-- did they would go here. -- did they would go here.
...@@ -800,7 +803,7 @@ configureFinalizedPackage ...@@ -800,7 +803,7 @@ configureFinalizedPackage
-> Compiler -> Compiler
-> Platform -> Platform
-> GenericPackageDescription -> GenericPackageDescription
-> IO PackageDescription -> IO (PackageDescription, FlagAssignment)
configureFinalizedPackage verbosity cfg configureFinalizedPackage verbosity cfg
allConstraints satisfies comp compPlatform pkg_descr0 = do allConstraints satisfies comp compPlatform pkg_descr0 = do
let enableTest t = t { testEnabled = fromFlag (configTests cfg) } let enableTest t = t { testEnabled = fromFlag (configTests cfg) }
...@@ -838,7 +841,7 @@ configureFinalizedPackage verbosity cfg ...@@ -838,7 +841,7 @@ configureFinalizedPackage verbosity cfg
++ intercalate ", " [ name ++ "=" ++ display value ++ intercalate ", " [ name ++ "=" ++ display value
| (FlagName name, value) <- flags ] | (FlagName name, value) <- flags ]
return pkg_descr return (pkg_descr, flags)
where where
addExtraIncludeLibDirs pkg_descr = addExtraIncludeLibDirs pkg_descr =
let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg
...@@ -1408,13 +1411,13 @@ reportComponentCycle cnames = ...@@ -1408,13 +1411,13 @@ reportComponentCycle cnames =
-- | This method computes a default, "good enough" 'ComponentId' -- | This method computes a default, "good enough" 'ComponentId'
-- for a package. The intent is that cabal-install (or the user) will -- for a package. The intent is that cabal-install (or the user) will
-- specify a more detailed IPID via the @--ipid@ flag if necessary. -- specify a more detailed IPID via the @--ipid@ flag if necessary.
computeComponentId :: PackageDescription computeComponentId :: PackageIdentifier
-> ComponentName -> ComponentName
-- TODO: careful here! -- TODO: careful here!
-> [ComponentId] -- IPIDs of the component dependencies -> [ComponentId] -- IPIDs of the component dependencies
-> FlagAssignment -> FlagAssignment
-> IO ComponentId -> ComponentId
computeComponentId pkg_descr cname dep_ipids flagAssignment = do computeComponentId pid cname dep_ipids flagAssignment = do
-- show is found to be faster than intercalate and then replacement of -- show is found to be faster than intercalate and then replacement of
-- special character used in intercalating. We cannot simply hash by -- special character used in intercalating. We cannot simply hash by
-- doubly concating list, as it just flatten out the nested list, so -- doubly concating list, as it just flatten out the nested list, so
...@@ -1423,11 +1426,11 @@ computeComponentId pkg_descr cname dep_ipids flagAssignment = do ...@@ -1423,11 +1426,11 @@ computeComponentId pkg_descr cname dep_ipids flagAssignment = do
-- For safety, include the package + version here -- For safety, include the package + version here
-- for GHC 7.10, where just the hash is used as -- for GHC 7.10, where just the hash is used as
-- the package key -- the package key
(display (package pkg_descr)) (display pid)
++ (show $ dep_ipids) ++ (show $ dep_ipids)
++ show flagAssignment ++ show flagAssignment
return . ComponentId $ ComponentId $
display (package pkg_descr) display pid
++ "-" ++ hash ++ "-" ++ hash
++ (case cname of ++ (case cname of
CLibName -> "" CLibName -> ""
...@@ -1436,16 +1439,118 @@ computeComponentId pkg_descr cname dep_ipids flagAssignment = do ...@@ -1436,16 +1439,118 @@ computeComponentId pkg_descr cname dep_ipids flagAssignment = do
CExeName s -> "-" ++ s ++ ".exe" CExeName s -> "-" ++ s ++ ".exe"
CTestName s -> "-" ++ s ++ ".test" CTestName s -> "-" ++ s ++ ".test"
CBenchName s -> "-" ++ s ++ ".bench") CBenchName s -> "-" ++ s ++ ".bench")
hashToBase62 :: String -> String
hashToBase62 s = showFingerprint $ fingerprintString s
where where
showIntAtBase62 x = showIntAtBase 62 representBase62 x ""
representBase62 x representBase62 x
| x < 10 = chr (48 + x) | x < 10 = chr (48 + x)
| x < 36 = chr (65 + x - 10) | x < 36 = chr (65 + x - 10)
| x < 62 = chr (97 + x - 36) | x < 62 = chr (97 + x - 36)
| otherwise = '@' | otherwise = '@'
fpToInteger (Fingerprint a b) = showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b
toInteger a * (shift (1 :: Integer) 64) + toInteger b
hashToBase62 s = showIntAtBase 62 representBase62 -- | In GHC 8.0, the string we pass to GHC to use for symbol
(fpToInteger $ fingerprintString s) "" -- names for a package can be an arbitrary, IPID-compatible string.
-- However, prior to GHC 8.0 there are some restrictions on what
-- format this string can be (due to how ghc-pkg parsed the key):
--
-- 1. In GHC 7.10, the string had either be of the form
-- foo_ABCD, where foo is a non-semantic alphanumeric/hyphenated
-- prefix and ABCD is two base-64 encoded 64-bit integers,
-- or a GHC 7.8 style identifier.
--
-- 2. In GHC 7.8, the string had to be a valid package identifier
-- like foo-0.1.
--
-- So, the problem is that Cabal, in general, has a general IPID,
-- but needs to figure out a package key / package ID that the
-- old ghc-pkg will actually accept. But there's an EVERY WORSE
-- problem: if ghc-pkg decides to parse an identifier foo-0.1-xxx
-- as if it were a package identifier, which means it will SILENTLY
-- DROP the "xxx" (because it's a tag, and Cabal does not allow tags.)
-- So we must CONNIVE to ensure that we don't pick something that
-- looks like this.
--
-- So this function attempts to define a mapping into the old formats.
--
-- The mapping for GHC 7.8 and before:
--
-- * For CLibName, we unconditionally use the 'PackageIdentifier'.
--
-- * For sub-components, we create a new 'PackageIdentifier' which
-- is encoded in the following way. The test suite "qux" in package
-- "foobar-0.2" gets this package identifier "z-foobar-z-test-qux-0.2".
-- These package IDs have the form:
--
-- cpid ::= "z-" package-id "-z-" component-type "-" component-name
-- component-type ::= "test" | "bench" | "exe" | "lib"
-- package-id and component-name have "-" ( "z" + ) "-"
-- segments encoded by adding an extra "z".
--
-- The mapping for GHC 7.10:
--
-- * For CLibName:
-- If the IPID is of the form foo-0.1-ABCDEF where foo_ABCDEF would
-- validly parse as a package key, we pass "ABCDEF". (NB: not
-- all hashes parse this way, because GHC 7.10 mandated that
-- these hashes be two base-62 encoded 64 bit integers),
-- but hashes that Cabal generated using 'computeComponentId'
-- are guaranteed to have this form.
--
-- If it is not of this form, we rehash the IPID into the
-- correct form and pass that.
--
-- * For sub-components, we rehash the IPID into the correct format
-- and pass that.
--
computeCompatPackageKey
:: Compiler
-> PackageIdentifier
-> ComponentName
-> ComponentId
-> (PackageName, ComponentId)
computeCompatPackageKey comp pid cname cid@(ComponentId str)
| not (packageKeySupported comp) =
-- NB: the package ID in the database entry has to follow this
let 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)
cname_str = case cname of
CLibName -> error "computeCompatPackageKey"
CTestName n -> "-z-test-" ++ zdashcode n
CBenchName n -> "-z-bench-" ++ zdashcode n
CExeName n -> "-z-exe-" ++ zdashcode n
package_name
| cname == CLibName = pkgName pid
| otherwise = PackageName $ "z-" ++ zdashcode (display (pkgName pid))
++ zdashcode cname_str
old_style_key
| cname == CLibName = display pid
| otherwise = display package_name ++ "-"
++ display (pkgVersion pid)
in (package_name, ComponentId old_style_key)
| not (unifiedIPIDRequired comp) =
let mb_verbatim_key
= case simpleParse str :: Maybe PackageId of
-- Something like 'foo-0.1', use it verbatim.
-- (NB: hash tags look like tags, so they are parsed,
-- so the extra equality check tests if a tag was dropped.)
Just pid0 | display pid0 == str -> Just str
_ -> Nothing
mb_truncated_key
= let cand = reverse (takeWhile isAlphaNum (reverse str))
in if length cand == 22 && all isAlphaNum cand
then Just cand
else Nothing
rehashed_key = hashToBase62 str
in (pkgName pid, ComponentId $ fromMaybe rehashed_key
(mb_verbatim_key `mplus` mb_truncated_key))
| otherwise = (pkgName pid, cid)
mkComponentsLocalBuildInfo :: ConfigFlags mkComponentsLocalBuildInfo :: ConfigFlags
-> Compiler -> Compiler
...@@ -1463,37 +1568,21 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr ...@@ -1463,37 +1568,21 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr
internalPkgDeps externalPkgDeps holePkgDeps hole_insts internalPkgDeps externalPkgDeps holePkgDeps hole_insts
graph flagAssignment = do graph flagAssignment = do
-- Pre-compute library hash so we can setup internal deps -- Pre-compute library hash so we can setup internal deps
lib_hash@(ComponentId str) <- -- TODO configIPID should have name changed
-- TODO configIPID should have name changed let cid = case configIPID cfg of
case configIPID cfg of Flag cid0 ->
Flag lib_hash0 -> -- Hack to reuse install dirs machinery
-- Hack to reuse install dirs machinery -- NB: no real IPID available at this point
-- NB: no real IPID available at this point let env = packageTemplateEnv (package pkg_descr)
let env = packageTemplateEnv (package pkg_descr) (ComponentId "") (ComponentId "")
str = fromPathTemplate (InstallDirs.substPathTemplate env (toPathTemplate lib_hash0)) str = fromPathTemplate
in return (ComponentId str) (InstallDirs.substPathTemplate env (toPathTemplate cid0))
_ -> in ComponentId str
computeComponentId pkg_descr CLibName (getDeps CLibName) flagAssignment _ ->
let extractCandidateCompatKey s computeComponentId (package pkg_descr) CLibName (getDeps CLibName) flagAssignment
= case simpleParse s :: Maybe PackageId of (_, compat_key) = computeCompatPackageKey comp (package pkg_descr) CLibName cid
-- Something like 'foo-0.1', use it verbatim.
-- (NB: hash tags look like tags, so they are parsed,
-- so the extra equality check tests if a tag was dropped.)
Just pid | display pid == s -> s
-- Something like 'foo-0.1-XXX', take the stuff at the end.
-- TODO this won't work with component stuff
_ -> reverse (takeWhile isAlphaNum (reverse s))
cand_compat_key = ComponentId (extractCandidateCompatKey str)
old_style_key = ComponentId (display (package pkg_descr))
best_key = ComponentId str
compat_key =
if packageKeySupported comp
then if unifiedIPIDRequired comp
then best_key
else cand_compat_key
else old_style_key
sequence sequence
[ do clbi <- componentLocalBuildInfo lib_hash compat_key c [ do clbi <- componentLocalBuildInfo cid compat_key c
return (componentName c, clbi, cdeps) return (componentName c, clbi, cdeps)
| (c, cdeps) <- graph ] | (c, cdeps) <- graph ]
where where
...@@ -1508,7 +1597,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr ...@@ -1508,7 +1597,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr
-- we just take the subset for the package names this component -- we just take the subset for the package names this component
-- needs. Note, this only works because we cannot yet depend on two -- needs. Note, this only works because we cannot yet depend on two
-- versions of the same package. -- versions of the same package.
componentLocalBuildInfo lib_hash compat_key component = componentLocalBuildInfo cid compat_key component =
case component of case component of
CLib lib -> do CLib lib -> do
let exports = map (\n -> Installed.ExposedModule n Nothing Nothing) let exports = map (\n -> Installed.ExposedModule n Nothing Nothing)
...@@ -1520,7 +1609,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr ...@@ -1520,7 +1609,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr
(PD.exposedSignatures lib) (PD.exposedSignatures lib)
let mb_reexports = resolveModuleReexports installedPackages let mb_reexports = resolveModuleReexports installedPackages
(packageId pkg_descr) (packageId pkg_descr)
lib_hash cid
externalPkgDeps lib externalPkgDeps lib
reexports <- case mb_reexports of reexports <- case mb_reexports of
Left problems -> reportModuleReexportProblems problems Left problems -> reportModuleReexportProblems problems
...@@ -1528,7 +1617,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr ...@@ -1528,7 +1617,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr
return LibComponentLocalBuildInfo { return LibComponentLocalBuildInfo {
componentPackageDeps = cpds, componentPackageDeps = cpds,
componentId = lib_hash, componentId = cid,
componentCompatPackageKey = compat_key, componentCompatPackageKey = compat_key,
componentPackageRenaming = cprns, componentPackageRenaming = cprns,
componentExposedModules = exports ++ reexports ++ esigs componentExposedModules = exports ++ reexports ++ esigs
...@@ -1555,7 +1644,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr ...@@ -1555,7 +1644,7 @@ mkComponentsLocalBuildInfo cfg comp installedPackages pkg_descr
then dedup $ then dedup $
[ (Installed.installedComponentId pkg, packageId pkg) [ (Installed.installedComponentId pkg, packageId pkg)
| pkg <- selectSubset bi externalPkgDeps ] | pkg <- selectSubset bi externalPkgDeps ]
++ [ (lib_hash, pkgid) ++ [ (cid, pkgid)
| pkgid <- selectSubset bi internalPkgDeps ] | pkgid <- selectSubset bi internalPkgDeps ]
else [ (Installed.installedComponentId pkg, packageId pkg) else [ (Installed.installedComponentId pkg, packageId pkg)
| pkg <- externalPkgDeps ]