Commit 1440ffd5 authored by Duncan Coutts's avatar Duncan Coutts Committed by Edward Z. Yang
Browse files

Change Graph.fromList to fromDistinctList and fix conseqeunces

It's really an error to try and build a graph where you have duplicate
node keys, so remove Graph.fromList and add Graph.fromDistinctList. This
check is always on, not just an assertion, becuase we get it for free
given the way Maps can be constructed.

All uses of Graph.fromList are ok to convert to fromDistinctList.
parent 5b4e95c6
......@@ -46,7 +46,8 @@ toComponentsGraph :: ComponentRequestedSpec
-> PackageDescription
-> Either [ComponentName] ComponentsGraph
toComponentsGraph enabled pkg_descr =
let g = Graph.fromList [ N c (componentName c) (componentDeps c)
let g = Graph.fromDistinctList
[ N c (componentName c) (componentDeps c)
| c <- pkgBuildableComponents pkg_descr
, componentEnabled enabled c ]
in case Graph.cycles g of
......
......@@ -116,7 +116,7 @@ configureComponentLocalBuildInfos
installedPackageSet (unDefUnitId uid)] ]
subst = Map.fromList instantiate_with
graph3 = toReadyComponents pid_map subst graph2
graph4 = Graph.revTopSort (Graph.fromList graph3)
graph4 = Graph.revTopSort (Graph.fromDistinctList graph3)
infoProgress $ hang (text "Ready component graph:") 4
(vcat (map dispReadyComponent graph4))
......@@ -146,11 +146,11 @@ toComponentLocalBuildInfos
-- they are not related to what we are building. This was true
-- in the old configure code.
external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
external_graph = Graph.fromList
external_graph = Graph.fromDistinctList
. map Left
$ PackageIndex.allPackages installedPackageSet
internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
internal_graph = Graph.fromList
internal_graph = Graph.fromDistinctList
. map Right
$ graph
combined_graph = Graph.unionRight external_graph internal_graph
......@@ -168,7 +168,7 @@ toComponentLocalBuildInfos
-- the include paths and everything should be.
--
packageDependsIndex = PackageIndex.fromList (lefts local_graph)
fullIndex = Graph.fromList local_graph
fullIndex = Graph.fromDistinctList local_graph
case Graph.broken fullIndex of
[] -> return ()
broken ->
......
......@@ -71,7 +71,7 @@ module Distribution.Compat.Graph (
-- ** Maps
toMap,
-- ** Lists
fromList,
fromDistinctList,
toList,
keys,
-- ** Sets
......@@ -89,7 +89,11 @@ import Distribution.Compat.Prelude hiding (lookup, null, empty)
import Data.Graph (SCC(..))
import qualified Data.Graph as G
#if MIN_VERSION_containers(0,5,0)
import qualified Data.Map.Strict as Map
#else
import qualified Data.Map as Map
#endif
import qualified Data.Set as Set
import qualified Data.Array as Array
import Data.Array ((!))
......@@ -121,12 +125,12 @@ data Graph a
instance Show a => Show (Graph a) where
show = show . toList
instance (IsNode a, Read a) => Read (Graph a) where
readsPrec d s = map (\(a,r) -> (fromList a, r)) (readsPrec d s)
instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where
readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s)
instance (IsNode a, Binary a) => Binary (Graph a) where
instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where
put x = put (toList x)
get = fmap fromList get
get = fmap fromDistinctList get
instance (Eq (Key a), Eq a) => Eq (Graph a) where
g1 == g2 = graphMap g1 == graphMap g2
......@@ -368,12 +372,14 @@ fromMap m
nodeTable = Array.listArray bounds ns
bounds = (0, Map.size m - 1)
-- | /O(V log V)/. Convert a list of nodes into a graph.
fromList :: IsNode a => [a] -> Graph a
fromList ns = fromMap
. Map.fromList
. map (\n -> n `seq` (nodeKey n, n))
$ ns
-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
fromDistinctList = fromMap
. Map.fromListWith (\_ -> duplicateError)
. map (\n -> n `seq` (nodeKey n, n))
where
duplicateError n = error $ "Graph.fromDistinctList: duplicate key: "
++ show (nodeKey n)
-- Map-like operations
......
......@@ -705,7 +705,7 @@ configure (pkg_descr0', pbi) cfg = do
compiler = comp,
hostPlatform = compPlatform,
buildDir = buildDir,
componentGraph = Graph.fromList buildComponents,
componentGraph = Graph.fromDistinctList buildComponents,
componentNameMap = buildComponentsMap,
installedPkgs = packageDependsIndex,
pkgDescrFile = Nothing,
......
......@@ -261,7 +261,7 @@ neededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -
neededTargetsInBuildOrder' pkg_descr lbi uids =
case Graph.closure (componentGraph lbi) uids of
Nothing -> error $ "localBuildPlan: missing uids " ++ intercalate ", " (map display uids)
Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromList clos))
Just clos -> map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (Graph.fromDistinctList clos))
-- | Execute @f@ for every 'TargetInfo' needed to build @uid@s, respecting
-- the build dependency order.
......
......@@ -72,7 +72,8 @@ hasNoDups = loop Set.empty
-- | Produces a graph of size @len@. We sample with 'suchThat'; if we
-- dropped duplicate entries our size could be smaller.
arbitraryGraph :: (Ord k, Arbitrary k, Arbitrary a) => Int -> Gen (Graph (Node k a))
arbitraryGraph :: (Ord k, Show k, Arbitrary k, Arbitrary a)
=> Int -> Gen (Graph (Node k a))
arbitraryGraph len = do
-- Careful! Assume k is much larger than size.
ks <- vectorOf len arbitrary `suchThat` hasNoDups
......@@ -81,9 +82,10 @@ arbitraryGraph len = do
ns <- listOf (elements ks)
-- Allow duplicates!
return (N a k ns)
return (fromList ns)
return (fromDistinctList ns)
instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Graph (Node k a)) where
instance (Ord k, Show k, Arbitrary k, Arbitrary a)
=> Arbitrary (Graph (Node k a)) where
arbitrary = sized $ \n -> do
len <- choose (0, n)
arbitraryGraph len
......@@ -752,13 +752,13 @@ validateSolverResult :: Platform
-> SolverInstallPlan
validateSolverResult platform comp indepGoals pkgs =
case planPackagesProblems platform comp pkgs of
[] -> case SolverInstallPlan.new indepGoals index of
[] -> case SolverInstallPlan.new indepGoals graph of
Right plan -> plan
Left problems -> error (formatPlanProblems problems)
problems -> error (formatPkgProblems problems)
where
index = Graph.fromList pkgs
graph = Graph.fromDistinctList pkgs
formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem
......@@ -769,11 +769,13 @@ validateSolverResult platform comp indepGoals pkgs =
: "The proposed (invalid) plan contained the following problems:"
: problems
++ "Proposed plan:"
: [SolverInstallPlan.showPlanIndex index]
: [SolverInstallPlan.showPlanIndex pkgs]
data PlanPackageProblem =
InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc) [PackageProblem]
InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc)
[PackageProblem]
| DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]
showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
......@@ -781,6 +783,9 @@ showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
++ " has an invalid configuration, in particular:\n"
++ unlines [ " " ++ showPackageProblem problem
| problem <- packageProblems ]
showPlanPackageProblem (DuplicatePackageSolverId pid dups) =
"Package " ++ display (packageId pid) ++ " has "
++ show (length dups) ++ " duplicate instances."
planPackagesProblems :: Platform -> CompilerInfo
-> [ResolverPackage UnresolvedPkgLoc]
......@@ -790,6 +795,8 @@ planPackagesProblems platform cinfo pkgs =
| Configured pkg <- pkgs
, let packageProblems = configuredPackageProblems platform cinfo pkg
, not (null packageProblems) ]
++ [ DuplicatePackageSolverId (Graph.nodeKey (head dups)) dups
| dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]
data PackageProblem = DuplicateFlag PD.FlagName
| MissingFlag PD.FlagName
......
......@@ -314,7 +314,7 @@ remove :: (IsUnit ipkg, IsUnit srcpkg)
remove shouldRemove plan =
mkInstallPlan "remove" newGraph (planIndepGoals plan)
where
newGraph = Graph.fromList $
newGraph = Graph.fromDistinctList $
filter (not . shouldRemove) (toList plan)
-- | Change a number of packages in the 'Configured' state to the 'Installed'
......@@ -416,7 +416,7 @@ fromSolverInstallPlan ::
-> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan f plan =
mkInstallPlan "fromSolverInstallPlan"
(Graph.fromList pkgs'')
(Graph.fromDistinctList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
(_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
......@@ -453,7 +453,7 @@ fromSolverInstallPlanWithProgress f plan = do
(_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])
(SolverInstallPlan.reverseTopologicalOrder plan)
return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
(Graph.fromList pkgs'')
(Graph.fromDistinctList pkgs'')
(SolverInstallPlan.planIndepGoals plan)
where
f' (pidMap, ipiMap, pkgs) pkg = do
......
......@@ -511,7 +511,7 @@ postBuildProjectStatus plan previousPackagesUpToDate
-- The plan graph but only counting dependency-on-library edges
packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
packagesLibDepGraph =
Graph.fromList
Graph.fromDistinctList
[ Graph.N pkg (installedUnitId pkg) libdeps
| pkg <- InstallPlan.toList plan
, let libdeps = case pkg of
......
......@@ -1779,8 +1779,9 @@ elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib
--TODO: [code cleanup] unused: the old deprecated packageConfigProfExe
libDepGraph = Graph.fromList (map NonSetupLibDepSolverPlanPackage
(SolverInstallPlan.toList solverPlan))
libDepGraph = Graph.fromDistinctList $
map NonSetupLibDepSolverPlanPackage
(SolverInstallPlan.toList solverPlan)
packagesWithLibDepsDownwardClosedProperty property =
Set.fromList
......@@ -1830,7 +1831,8 @@ getComponentId (InstallPlan.Installed elab) = elabComponentId elab
instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan
instantiateInstallPlan plan =
InstallPlan.new (IndependentGoals False) (Graph.fromList (Map.elems ready_map))
InstallPlan.new (IndependentGoals False)
(Graph.fromDistinctList (Map.elems ready_map))
where
pkgs = InstallPlan.toList plan
......@@ -2048,7 +2050,7 @@ pruneInstallPlanToTargets :: Map UnitId [PackageTarget]
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets perPkgTargetsMap elaboratedPlan =
InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
. Graph.fromList
. Graph.fromDistinctList
-- We have to do this in two passes
. pruneInstallPlanPass2
. pruneInstallPlanPass1 perPkgTargetsMap
......@@ -2095,7 +2097,7 @@ pruneInstallPlanPass1 perPkgTargetsMap pkgs =
(fromMaybe [] $ Graph.closure g roots)
where
pkgs' = map (mapConfiguredPackage prune) pkgs
g = Graph.fromList pkgs'
g = Graph.fromDistinctList pkgs'
prune elab =
let elab' = (pruneOptionalStanzas . setElabBuildTargets) elab
......@@ -2349,7 +2351,7 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
. checkBrokenDeps
. Graph.fromList
. Graph.fromDistinctList
. filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)
. InstallPlan.toList
$ installPlan
......
......@@ -121,12 +121,11 @@ instance Binary SolverInstallPlan where
(index, indepGoals) <- get
return $! mkInstallPlan index indepGoals
showPlanIndex :: SolverPlanIndex -> String
showPlanIndex index =
intercalate "\n" (map showPlanPackage (Graph.toList index))
showPlanIndex :: [SolverPlanPackage] -> String
showPlanIndex = intercalate "\n" . map showPlanPackage
showInstallPlan :: SolverInstallPlan -> String
showInstallPlan = showPlanIndex . planIndex
showInstallPlan = showPlanIndex . toList
showPlanPackage :: SolverPlanPackage -> String
showPlanPackage (PreExisting ipkg) = "PreExisting " ++ display (packageId ipkg)
......@@ -163,7 +162,7 @@ remove :: (SolverPlanPackage -> Bool)
remove shouldRemove plan =
new (planIndepGoals plan) newIndex
where
newIndex = Graph.fromList $
newIndex = Graph.fromDistinctList $
filter (not . shouldRemove) (toList plan)
-- ------------------------------------------------------------
......
......@@ -73,7 +73,7 @@ findCycles pkg rdm =
then let scc :: G.Graph RevDepMapNode
scc = case G.cycles $ revDepMapToGraph rdm of
[] -> findCyclesError "cannot find a strongly connected component"
c : _ -> G.fromList c
c : _ -> G.fromDistinctList c
next :: QPN -> QPN
next p = case G.neighbors scc p of
......@@ -115,5 +115,5 @@ instance G.IsNode RevDepMapNode where
nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns
revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
revDepMapToGraph rdm = G.fromList
revDepMapToGraph rdm = G.fromDistinctList
[RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]
......@@ -233,8 +233,9 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do
| pkgv <- srcpkgvs
, let depvs = graph ! pkgv
]
let index = Graph.fromList (map InstallPlan.PreExisting ipkgs
++ map InstallPlan.Configured srcpkgs)
let index = Graph.fromDistinctList
(map InstallPlan.PreExisting ipkgs
++ map InstallPlan.Configured srcpkgs)
return $ InstallPlan.new (IndependentGoals False) index
......
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