Commit 6fead251 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov Committed by GitHub
Browse files

Merge pull request #4303 from ezyang/pr/backpack-improv

Backpack improvements
parents bd6d5c8e 1b95d3a6
......@@ -50,7 +50,6 @@ import Data.Either
import qualified Data.Set as Set
import qualified Data.Map as Map
import Distribution.Text
( display )
import Text.PrettyPrint
------------------------------------------------------------------------------
......@@ -216,13 +215,15 @@ toComponentLocalBuildInfos
$ packageDependsIndex of
[] -> return ()
inconsistencies ->
warnProgress . text $
"This package indirectly depends on multiple versions of the same "
++ "package. This is highly likely to cause a compile failure.\n"
++ unlines [ "package " ++ display pkg ++ " requires "
++ display (PackageIdentifier name ver)
| (name, uses) <- inconsistencies
, (pkg, ver) <- uses ]
warnProgress $
hang (text "This package indirectly depends on multiple versions of the same" <+>
text "package. This is highly likely to cause a compile failure.") 2
(vcat [ text "package" <+> disp (packageName user) <+>
parens (disp (installedUnitId user)) <+> text "requires" <+>
disp inst
| (_dep_key, insts) <- inconsistencies
, (inst, users) <- insts
, user <- users ])
let clbis = mkLinkedComponentsLocalBuildInfo comp graph
-- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
return (clbis, packageDependsIndex)
......
......@@ -132,8 +132,9 @@ import System.IO
import Distribution.Text
( Text(disp), defaultStyle, display, simpleParse )
import Text.PrettyPrint
( Doc, (<+>), ($+$), char, comma, hsep, nest
( Doc, (<+>), ($+$), ($$), char, comma, hsep, nest, hang, vcat
, punctuate, quotes, render, renderStyle, sep, text )
import qualified Text.PrettyPrint as Disp
import Distribution.Compat.Environment ( lookupEnv )
import Distribution.Compat.Exception ( catchExit, catchIO )
......@@ -360,15 +361,14 @@ configure (pkg_descr0', pbi) cfg = do
let use_external_internal_deps = isJust mb_cname
case mb_cname of
Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0)
Just cname -> notice verbosity
("Configuring component " ++ display cname ++
" from " ++ display (packageId pkg_descr0) ++
(if null (configInstantiateWith cfg)
then ""
else " with " ++ intercalate ", "
[ display k ++ "=" ++ display v
| (k,v) <- configInstantiateWith cfg ]) ++
"...")
Just cname -> noticeDoc verbosity $
text "Configuring component" <+> disp cname <+>
text "from" <+> disp (packageId pkg_descr0) $$
if null (configInstantiateWith cfg)
then Disp.empty
else hang (text "Instantiated with:") 2
(vcat [ disp k <<>> "=" <<>> disp v
| (k,v) <- configInstantiateWith cfg ])
-- configCID is only valid for per-component configure
when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $
......
......@@ -127,6 +127,7 @@ import qualified Data.Array as Array
import qualified Data.Graph as Graph
import Data.List as List ( groupBy, deleteBy, deleteFirstsBy )
import qualified Data.Tree as Tree
import Control.Monad
-- | The collection of information about packages from one or more 'PackageDB's.
-- These packages generally should have an instance of 'PackageInstalled'
......@@ -629,6 +630,10 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
topBound = length pkgs - 1
bounds = (0, topBound)
-- | We maintain the invariant that, for any 'DepUniqueKey', there
-- is only one instance of the package in our database.
type DepUniqueKey = (PackageName, Map ModuleName OpenModule)
-- | Given a package index where we assume we want to use all the packages
-- (use 'dependencyClosure' if you need to get such a index subset) find out
-- if the dependencies within it use consistent versions of each package.
......@@ -640,45 +645,26 @@ dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
-- distinct.
--
dependencyInconsistencies :: InstalledPackageIndex
-> [(PackageName, [(PackageId, Version)])]
dependencyInconsistencies index =
[ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])
| (name, cid_map) <- Map.toList inverseIndex
, let uses = Map.elems cid_map
, reallyIsInconsistent (map fst uses) ]
where -- for each PackageName,
-- for each package with that name,
-- the InstalledPackageInfo and the package Ids of packages
-- that depend on it.
--
-- NB: we use ComponentId here, not UnitId, because there might
-- be multiple occurrences of a package name with different
-- instantiations. However, the component IDs will always be
-- consistent!
inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))
[ (packageName dep,
Map.fromList [(cid,(dep,[packageId pkg]))])
| pkg <- allPackages index
, ipid <- installedDepends pkg
, Just dep <- [lookupUnitId index ipid]
, let cid = IPI.installedComponentId dep
]
-- Added in 991e52a474e2b8280432257c1771dc474a320a30,
-- this is a special case to handle the base 3 compatibility
-- package which shipped with GHC 6.10 and GHC 6.12
-- (it was removed in GHC 7.0). Remove this when GHC 6.12
-- goes out of our support window.
reallyIsInconsistent :: PackageInstalled a => [a] -> Bool
reallyIsInconsistent [] = False
reallyIsInconsistent [_p] = False
reallyIsInconsistent [p1, p2] =
let pid1 = installedUnitId p1
pid2 = installedUnitId p2
in pid1 `notElem` installedDepends p2
&& pid2 `notElem` installedDepends p1
reallyIsInconsistent _ = True
-- At DepUniqueKey...
-> [(DepUniqueKey,
-- There were multiple packages (BAD!)
[(UnitId,
-- And here are the packages which
-- immediately depended on it
[IPI.InstalledPackageInfo])])]
dependencyInconsistencies index = do
(dep_key, insts_map) <- Map.toList inverseIndex
let insts = Map.toList insts_map
guard (length insts >= 2)
return (dep_key, insts)
where
inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo])
inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do
pkg <- allPackages index
dep_ipid <- installedDepends pkg
Just dep <- [lookupUnitId index dep_ipid]
let dep_key = (packageName dep, Map.fromList (IPI.instantiatedWith dep))
return (dep_key, Map.singleton dep_ipid [pkg])
-- | A rough approximation of GHC's module finder, takes a
-- 'InstalledPackageIndex' and turns it into a map from module names to their
......
......@@ -29,7 +29,9 @@ module Distribution.Simple.Utils (
dieWithLocation,
dieMsg, dieMsgNoWrap,
topHandler, topHandlerWith,
warn, notice, noticeNoWrap, setupMessage, info, debug,
warn,
notice, noticeNoWrap, noticeDoc,
setupMessage, info, debug,
debugNoWrap, chattyTry,
printRawCommandAndArgs, printRawCommandAndArgsAndEnv,
......@@ -227,6 +229,8 @@ import System.Process
( ProcessHandle, createProcess, rawSystem, runInteractiveProcess
, showCommandForUser, waitForProcess)
import qualified Text.PrettyPrint as Disp
-- We only get our own version number when we're building with ourselves
cabalVersion :: Version
#if defined(BOOTSTRAPPED_CABAL)
......@@ -362,6 +366,15 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do
hPutCallStackPrefix stdout verbosity
putStr msg
-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
-- level. Use this if you need fancy formatting.
--
noticeDoc :: Verbosity -> Disp.Doc -> IO ()
noticeDoc verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do
hPutCallStackPrefix stdout verbosity
putStrLn (Disp.renderStyle defaultStyle msg)
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity msg pkgid = withFrozenCallStack $ do
notice verbosity (msg ++ ' ': display pkgid ++ "...")
......
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