Merge pull request #3628 from phadej/installplan-refactor

Installplan refactor
haskell · Jul 26, 2016 · 334e968 · 334e968
2 parents 12d308c + 9ccdc2f
commit 334e968
Show file tree

Hide file tree

Showing 17 changed files with 914 additions and 652 deletions.
diff --git a/Cabal/Distribution/Compat/Graph.hs b/Cabal/Distribution/Compat/Graph.hs
@@ -60,6 +60,8 @@ module Distribution.Compat.Graph (
     SCC(..),
     cycles,
     broken,
+    neighbors,
+    revNeighbors,
     closure,
     revClosure,
     topSort,
@@ -273,6 +275,20 @@ cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ]
 broken :: Graph a -> [(a, [Key a])]
 broken g = graphBroken g
 
+-- | Lookup the immediate neighbors from a key in the graph.
+-- Requires amortized construction of graph.
+neighbors :: Graph a -> Key a -> Maybe [a]
+neighbors g k = do
+    v <- graphKeyToVertex g k
+    return (map (graphVertexToNode g) (graphForward g ! v))
+
+-- | Lookup the immediate reverse neighbors from a key in the graph.
+-- Requires amortized construction of graph.
+revNeighbors :: Graph a -> Key a -> Maybe [a]
+revNeighbors g k = do
+    v <- graphKeyToVertex g k
+    return (map (graphVertexToNode g) (graphAdjoint g ! v))
+
 -- | Compute the subgraph which is the closure of some set of keys.
 -- Returns @Nothing@ if one (or more) keys are not present in
 -- the graph.

diff --git a/Cabal/tests/UnitTests/Distribution/Compat/Graph.hs b/Cabal/tests/UnitTests/Distribution/Compat/Graph.hs
@@ -78,9 +78,9 @@ arbitraryGraph len = do
     ks <- vectorOf len arbitrary `suchThat` hasNoDups
     ns <- forM ks $ \k -> do
         a <- arbitrary
-        neighbors <- listOf (elements ks)
+        ns <- listOf (elements ks)
         -- Allow duplicates!
-        return (N a k neighbors)
+        return (N a k ns)
     return (fromList ns)
 
 instance (Ord k, Arbitrary k, Arbitrary a) => Arbitrary (Graph (Node k a)) where

diff --git a/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -123,39 +123,36 @@ storeLocal cinfo templates reports platform = sequence_
 
 fromInstallPlan :: Platform -> CompilerId
                 -> InstallPlan
+                -> BuildResults
                 -> [(BuildReport, Maybe Repo)]
-fromInstallPlan platform comp plan =
+fromInstallPlan platform comp plan buildResults =
      catMaybes
-   . map (fromPlanPackage platform comp)
+   . map (\pkg -> fromPlanPackage
+                    platform comp pkg
+                    (InstallPlan.lookupBuildResult pkg buildResults))
    . InstallPlan.toList
    $ plan
 
 fromPlanPackage :: Platform -> CompilerId
                 -> InstallPlan.PlanPackage
+                -> Maybe BuildResult
                 -> Maybe (BuildReport, Maybe Repo)
-fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
-  InstallPlan.Installed (ReadyPackage (ConfiguredPackage _ srcPkg flags _ deps))
-                         _ result
-    -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags
-                                (map packageId (CD.nonSetupDeps deps))
-                                (Right result)
-              , extractRepo srcPkg)
-
-  InstallPlan.Failed (ConfiguredPackage _ srcPkg flags _ deps) result
-    -> Just $ ( BuildReport.new os arch comp
-                                (packageId srcPkg) flags
-                                (map confSrcId (CD.nonSetupDeps deps))
-                                (Left result)
-              , extractRepo srcPkg )
-
-  _ -> Nothing
-
+fromPlanPackage (Platform arch os) comp
+                (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))
+                (Just buildResult) =
+      Just ( BuildReport.new os arch comp
+                             (packageId srcPkg) flags
+                             (map packageId (CD.nonSetupDeps deps))
+                             buildResult
+           , extractRepo srcPkg)
   where
     extractRepo (SourcePackage { packageSource = RepoTarballPackage repo _ _ })
                   = Just repo
     extractRepo _ = Nothing
 
+fromPlanPackage _ _ _ _ = Nothing
+
+
 fromPlanningFailure :: Platform -> CompilerId
     -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
 fromPlanningFailure (Platform arch os) comp pkgids flags =

diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs
@@ -138,7 +138,7 @@ configure verbosity packageDBs repoCtxt comp platform conf
 
     Right installPlan0 ->
      let installPlan = InstallPlan.configureInstallPlan installPlan0
-     in case InstallPlan.ready installPlan of
+     in case fst (InstallPlan.ready installPlan) of
       [pkg@(ReadyPackage
               (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)
                                  _ _ _))] -> do