Commit 41610a0b authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Implement package keys, distinguishing packages built with different deps/flags



Previously, the GHC ecosystem assumed that for any package ID (foo-0.1), there
would only be one instance of it in the installed packages database.  This
posed problems for situations where you want a package compiled twice against
different sets of dependencies: they could not both exist in the package
database.

Package keys are a hash of the package ID and package
dependencies, which identify a package more uniquely than a package ID, but less
uniquely than an installed package ID. Unlike installed package IDs, these can
be computed immediately after dependency resolution, rather than after
compilation.  Package keys require support from the compiler.  At the moment,
only GHC 7.10 supports package keys (the reason is that old versions of GHC
do a sannity check to see that the <pkg-name>-<pkg-version> stored in the
package database matches with the -package-name embedded in an hi file; so
the format is fixed.) We fallback to package keys == package IDs for old
versions.

Note: the ./Setup configure fallback script does not try particularly hard to
pick consistent sets of dependencies.  If your package database is too difficult
for it to resolve, manually provide installed package IDs or use cabal-install's
dependency solver.

Note: This patch *suspends* the reinstall check unless it would result in
a different package, so cabal-install will now happily reinstall foo-0.1
compiled against bar-0.2 if foo-0.1 already exists.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent c0537226
......@@ -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
-- ------------------------------------------------------------
......
......@@ -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 )
......@@ -115,7 +117,7 @@ import Prelude hiding ( mapM )
import Control.Monad
( when, unless, foldM, filterM )
import Data.List
( (\\), nub, partition, isPrefixOf, inits )
( (\\), nub, partition, isPrefixOf, inits, find )
import Data.Maybe
( isNothing, catMaybes, fromMaybe )
import Data.Monoid
......@@ -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,
......
......@@ -65,7 +65,7 @@ import Distribution.PackageDescription
, Executable(exeName, buildInfo), withTest, TestSuite(..)
, BuildInfo(buildable), Benchmark(..) )
import Distribution.Package
( PackageId, Package(..), InstalledPackageId(..) )
( PackageId, Package(..), InstalledPackageId(..), PackageKey )
import Distribution.Simple.Compiler
( Compiler(..), PackageDBStack, OptimisationLevel )
import Distribution.Simple.PackageIndex
......@@ -115,6 +115,9 @@ data LocalBuildInfo = LocalBuildInfo {
localPkgDescr :: PackageDescription,
-- ^ The resolved package description, that does not contain
-- any conditionals.
pkgKey :: PackageKey,
-- ^ The package key for the current build, calculated from
-- the package ID and the dependency graph.
withPrograms :: ProgramConfiguration, -- ^Location and args for all programs
withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user
withVanillaLib:: Bool, -- ^Whether to build normal libs.
......
......@@ -67,8 +67,8 @@ data GhcOptions = GhcOptions {
-------------
-- Packages
-- | The package name the modules will belong to; the @ghc -package-name@ flag
ghcOptPackageName :: Flag PackageId,
-- | The package key the modules will belong to; the @ghc -this-package-key@ flag
ghcOptPackageKey :: Flag PackageKey,
-- | GHC package databases to use, the @ghc -package-conf@ flag
ghcOptPackageDBs :: PackageDBStack,
......@@ -322,7 +322,10 @@ renderGhcOptions comp opts
-------------
-- Packages
, concat [ ["-package-name", display pkgid] | pkgid <- flag ghcOptPackageName ]
, concat [ [if packageKeySupported comp
then "-this-package-key"
else "-package-name", display pkgid]
| pkgid <- flag ghcOptPackageKey ]
, [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ]
, [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]
......@@ -416,7 +419,7 @@ instance Monoid GhcOptions where
ghcOptOutputDynFile = mempty,
ghcOptSourcePathClear = mempty,
ghcOptSourcePath = mempty,
ghcOptPackageName = mempty,
ghcOptPackageKey = mempty,
ghcOptPackageDBs = mempty,
ghcOptPackages = mempty,
ghcOptHideAllPackages = mempty,
......@@ -465,7 +468,7 @@ instance Monoid GhcOptions where
ghcOptOutputDynFile = combine ghcOptOutputDynFile,
ghcOptSourcePathClear = combine ghcOptSourcePathClear,
ghcOptSourcePath = combine ghcOptSourcePath,
ghcOptPackageName = combine ghcOptPackageName,
ghcOptPackageKey = combine ghcOptPackageKey,
ghcOptPackageDBs = combine ghcOptPackageDBs,
ghcOptPackages = combine ghcOptPackages,
ghcOptHideAllPackages = combine ghcOptHideAllPackages,
......
......@@ -258,14 +258,16 @@ generalInstalledPackageInfo
-- absolute paths.
-> PackageDescription
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> InstallDirs FilePath
-> InstalledPackageInfo
generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =
generalInstalledPackageInfo adjustRelIncDirs pkg lib lbi clbi installDirs =
InstalledPackageInfo {
--TODO: do not open-code this conversion from PackageId to InstalledPackageId
IPI.installedPackageId = InstalledPackageId (display (packageId pkg)),
IPI.sourcePackageId = packageId pkg,
IPI.packageKey = pkgKey lbi,
IPI.license = license pkg,
IPI.copyright = copyright pkg,
IPI.maintainer = maintainer pkg,
......@@ -324,7 +326,7 @@ inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =
generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib clbi
generalInstalledPackageInfo adjustRelativeIncludeDirs pkg lib lbi clbi
installDirs
where
adjustRelativeIncludeDirs = map (inplaceDir </>)
......@@ -352,7 +354,7 @@ absoluteInstalledPackageInfo :: PackageDescription
-> ComponentLocalBuildInfo
-> InstalledPackageInfo
absoluteInstalledPackageInfo pkg lib lbi clbi =
generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs
generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib lbi clbi installDirs
where
-- For installed packages we install all include files into one dir,
-- whereas in the build tree they may live in multiple local dirs.
......
......@@ -99,7 +99,7 @@ import Distribution.Client.JobControl
import Distribution.Simple.Compiler
( CompilerId(..), Compiler(compilerId), compilerFlavor
, PackageDB(..), PackageDBStack )
, PackageDB(..), PackageDBStack, packageKeySupported )
import Distribution.Simple.Program (ProgramConfiguration,
defaultProgramConfiguration)
import qualified Distribution.Simple.InstallDirs as InstallDirs
......@@ -122,7 +122,7 @@ import Distribution.Simple.InstallDirs as InstallDirs
, initialPathTemplateEnv, installDirsTemplateEnv )
import Distribution.Package
( PackageIdentifier, PackageId, packageName, packageVersion
, Package(..), PackageFixedDeps(..)
, Package(..), PackageFixedDeps(..), mkPackageKey
, Dependency(..), thisPackageVersion, InstalledPackageId )
import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription
......@@ -280,10 +280,10 @@ processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> InstallPlan
-> IO ()
processInstallPlan verbosity
args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)
args@(_,_, comp, _, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers) installPlan = do
checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
checkPrintPlan verbosity comp installedPkgIndex installPlan sourcePkgDb
installFlags pkgSpecifiers
unless (dryRun || nothingToInstall) $ do
......@@ -422,13 +422,14 @@ pruneInstallPlan pkgSpecifiers =
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
checkPrintPlan :: Verbosity
-> Compiler
-> PackageIndex
-> InstallPlan
-> SourcePackageDb
-> InstallFlags
-> [PackageSpecifier SourcePackage]
-> IO ()
checkPrintPlan verbosity installed installPlan sourcePkgDb
checkPrintPlan verbosity comp installed installPlan sourcePkgDb
installFlags pkgSpecifiers = do
-- User targets that are already installed.
......@@ -445,7 +446,7 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb
: map (display . packageId) preExistingTargets
++ ["Use --reinstall if you want to reinstall anyway."]
let lPlan = linearizeInstallPlan installed installPlan
let lPlan = linearizeInstallPlan comp installed installPlan
-- Are any packages classified as reinstalls?
let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan
-- Packages that are already broken.
......@@ -497,10 +498,11 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb
dryRun = fromFlag (installDryRun installFlags)
overrideReinstall = fromFlag (installOverrideReinstall installFlags)
linearizeInstallPlan :: PackageIndex
linearizeInstallPlan :: Compiler
-> PackageIndex
-> InstallPlan
-> [(ReadyPackage, PackageStatus)]
linearizeInstallPlan installedPkgIndex plan =
linearizeInstallPlan comp installedPkgIndex plan =
unfoldr next plan
where
next plan' = case InstallPlan.ready plan' of
......@@ -508,7 +510,7 @@ linearizeInstallPlan installedPkgIndex plan =
(pkg:_) -> Just ((pkg, status), plan'')
where
pkgid = packageId pkg
status = packageStatus installedPkgIndex pkg
status = packageStatus comp installedPkgIndex pkg
plan'' = InstallPlan.completed pkgid
(BuildOk DocsNotTried TestsNotTried
(Just $ Installed.emptyInstalledPackageInfo
......@@ -527,19 +529,22 @@ extractReinstalls :: PackageStatus -> [InstalledPackageId]
extractReinstalls (Reinstall ipids _) = ipids
extractReinstalls _ = []
packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus
packageStatus installedPkgIndex cpkg =
packageStatus :: Compiler -> PackageIndex -> ReadyPackage -> PackageStatus
packageStatus comp installedPkgIndex cpkg@(ReadyPackage pid flags _ deps) =
case PackageIndex.lookupPackageName installedPkgIndex
(packageName cpkg) of
[] -> NewPackage
ps -> case filter ((==packageId cpkg)
. Installed.sourcePackageId) (concatMap snd ps) of
ps -> case filter ((==pkg_key)
. Installed.packageKey) (concatMap snd ps) of
[] -> NewVersion (map fst ps)
pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)
(changes pkg cpkg)
where
pkg_key = mkPackageKey (packageKeySupported comp)
(packageId pid) (map Installed.packageKey deps) flags
changes :: Installed.InstalledPackageInfo
-> ReadyPackage
-> [MergeResult PackageIdentifier PackageIdentifier]
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment