diff --git a/Cabal/Distribution/Compat/Graph.hs b/Cabal/Distribution/Compat/Graph.hs index cb92afbd9d3..76b04013dfd 100644 --- 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, @@ -266,6 +268,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 index 88cab54aa8f..b03717ba781 100644 --- 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 index 591b29c180a..af265950ffc 100644 --- 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 index 57f681ed90a..b5a1881855e 100644 --- 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 diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index b2e51cf3ffd..e42cc350830 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -32,7 +32,7 @@ module Distribution.Client.Install ( import Data.Foldable ( traverse_ ) import Data.List - ( isPrefixOf, unfoldr, nub, sort, (\\), find ) + ( isPrefixOf, nub, sort, (\\) ) import qualified Data.Map as Map import qualified Data.Set as S import Data.Maybe @@ -339,13 +339,13 @@ processInstallPlan verbosity installFlags pkgSpecifiers unless (dryRun || nothingToInstall) $ do - installPlan' <- performInstallations verbosity - args installedPkgIndex installPlan - postInstallActions verbosity args userTargets installPlan' + buildResults <- performInstallations verbosity + args installedPkgIndex installPlan + postInstallActions verbosity args userTargets installPlan buildResults where installPlan = InstallPlan.configureInstallPlan installPlan0 dryRun = fromFlag (installDryRun installFlags) - nothingToInstall = null (InstallPlan.ready installPlan) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) -- ------------------------------------------------------------ -- * Installation planning @@ -512,9 +512,15 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb : map (display . packageId) preExistingTargets ++ ["Use --reinstall if you want to reinstall anyway."] - let lPlan = linearizeInstallPlan installed installPlan + let lPlan = + [ (pkg, status) + | pkg <- InstallPlan.executionOrder installPlan + , let status = packageStatus installed pkg ] -- Are any packages classified as reinstalls? - let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan + let reinstalledPkgs = + [ ipkg + | (_pkg, status) <- lPlan + , ipkg <- extractReinstalls status ] -- Packages that are already broken. let oldBrokenPkgs = map Installed.installedUnitId @@ -575,44 +581,11 @@ checkPrintPlan verbosity installed installPlan sourcePkgDb ++ "\nTry using 'cabal fetch'." where - nothingToInstall = null (InstallPlan.ready installPlan) + nothingToInstall = null (fst (InstallPlan.ready installPlan)) dryRun = fromFlag (installDryRun installFlags) overrideReinstall = fromFlag (installOverrideReinstall installFlags) --- | Given an 'InstallPlan', perform a dry run, producing the sequence --- of 'ReadyPackage's which would be compiled in order to carry --- out this plan. This function is not actually used to execute a plan; --- presently, it is used only to (1) determine if the installation --- plan would cause reinstalls and (2) to print out what would be --- installed. --- --- TODO: this type is too specific -linearizeInstallPlan :: InstalledPackageIndex - -> InstallPlan - -> [(ReadyPackage, PackageStatus)] -linearizeInstallPlan installedPkgIndex plan = - unfoldr next plan - where - next plan' = case InstallPlan.ready plan' of - [] -> Nothing - (pkg:_) -> Just ((pkg, status), plan'') - where - pkgid = installedUnitId pkg - status = packageStatus installedPkgIndex pkg - ipkg = Installed.emptyInstalledPackageInfo { - Installed.sourcePackageId = packageId pkg, - Installed.installedUnitId = pkgid - } - plan'' = InstallPlan.completed pkgid (Just ipkg) - (BuildOk DocsNotTried TestsNotTried [ipkg]) - (InstallPlan.processing [pkg] plan') - --FIXME: This is a bit of a hack, - -- pretending that each package is installed - -- It's doubly a hack because the installed package ID - -- didn't get updated. But it doesn't really matter - -- because we're not going to use this for anything real. - data PackageStatus = NewPackage | NewVersion [Version] | Reinstall [UnitId] [PackageChange] @@ -835,11 +808,12 @@ postInstallActions :: Verbosity -> InstallArgs -> [UserTarget] -> InstallPlan + -> BuildResults -> IO () postInstallActions verbosity (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo ,globalFlags, configFlags, _, installFlags, _) - targets installPlan = do + targets installPlan buildResults = do unless oneShot $ World.insert verbosity worldFile @@ -848,7 +822,7 @@ postInstallActions verbosity | UserTargetNamed dep <- targets ] let buildReports = BuildReports.fromInstallPlan platform (compilerId comp) - installPlan + installPlan buildResults BuildReports.storeLocal (compilerInfo comp) (fromNubList $ installSummaryFile installFlags) buildReports @@ -859,14 +833,15 @@ postInstallActions verbosity storeDetailedBuildReports verbosity logsDir buildReports regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox - configFlags installFlags installPlan + configFlags installFlags buildResults - symlinkBinaries verbosity platform comp configFlags installFlags installPlan + symlinkBinaries verbosity platform comp configFlags installFlags + installPlan buildResults - printBuildFailures installPlan + printBuildFailures buildResults updateSandboxTimestampsFile useSandbox mSandboxPkgInfo - comp platform installPlan + comp platform installPlan buildResults where reportingLevel = fromFlag (installBuildReports installFlags) @@ -916,10 +891,10 @@ regenerateHaddockIndex :: Verbosity -> UseSandbox -> ConfigFlags -> InstallFlags - -> InstallPlan + -> BuildResults -> IO () regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox - configFlags installFlags installPlan + configFlags installFlags buildResults | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do defaultDirs <- InstallDirs.defaultInstallDirs @@ -947,14 +922,14 @@ regenerateHaddockIndex verbosity packageDBs comp platform conf useSandbox -- #1337), we don't do it for global installs or special cases where we're -- installing into a specific db. shouldRegenerateHaddockIndex = (isUseSandbox useSandbox || normalUserInstall) - && someDocsWereInstalled installPlan + && someDocsWereInstalled buildResults where - someDocsWereInstalled = any installedDocs . InstallPlan.toList + someDocsWereInstalled = any installedDocs . Map.elems + installedDocs (Right (BuildOk DocsOk _ _)) = True + installedDocs _ = False + normalUserInstall = (UserPackageDB `elem` packageDBs) && all (not . isSpecificPackageDB) packageDBs - - installedDocs (InstallPlan.Installed _ _ (BuildOk DocsOk _ _)) = True - installedDocs _ = False isSpecificPackageDB (SpecificPackageDB _) = True isSpecificPackageDB _ = False @@ -976,11 +951,13 @@ symlinkBinaries :: Verbosity -> ConfigFlags -> InstallFlags -> InstallPlan + -> BuildResults -> IO () -symlinkBinaries verbosity platform comp configFlags installFlags plan = do +symlinkBinaries verbosity platform comp configFlags installFlags + plan buildResults = do failed <- InstallSymlink.symlinkBinaries platform comp configFlags installFlags - plan + plan buildResults case failed of [] -> return () [(_, exe, path)] -> @@ -1002,16 +979,15 @@ symlinkBinaries verbosity platform comp configFlags installFlags plan = do bindir = fromFlag (installSymlinkBinDir installFlags) -printBuildFailures :: InstallPlan - -> IO () -printBuildFailures plan = - case [ (pkg, reason) - | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of +printBuildFailures :: BuildResults -> IO () +printBuildFailures buildResults = + case [ (pkgid, failure) + | (pkgid, Left failure) <- Map.toList buildResults ] of [] -> return () failed -> die . unlines $ "Error: some packages failed to install:" - : [ display (packageId pkg) ++ printFailureReason reason - | (pkg, reason) <- failed ] + : [ display pkgid ++ printFailureReason reason + | (pkgid, reason) <- failed ] where printFailureReason reason = case reason of DependentFailed pkgid -> " depends on " ++ display pkgid @@ -1049,21 +1025,26 @@ printBuildFailures plan = updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo -> Compiler -> Platform -> InstallPlan + -> BuildResults -> IO () updateSandboxTimestampsFile (UseSandbox sandboxDir) (Just (SandboxPackageInfo _ _ _ allAddSourceDeps)) - comp platform installPlan = + comp platform installPlan buildResults = withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do - let allInstalled = [ pkg | InstallPlan.Installed pkg _ _ - <- InstallPlan.toList installPlan ] - allSrcPkgs = [ confPkgSource cpkg | ReadyPackage cpkg - <- allInstalled ] + let allInstalled = [ pkg + | InstallPlan.Configured pkg + <- InstallPlan.toList installPlan + , case InstallPlan.lookupBuildResult pkg buildResults of + Just (Right _success) -> True + _ -> False + ] + allSrcPkgs = [ confPkgSource cpkg | cpkg <- allInstalled ] allPaths = [ pth | LocalUnpackedPackage pth <- map packageSource allSrcPkgs] allPathsCanonical <- mapM tryCanonicalizePath allPaths return $! filter (`S.member` allAddSourceDeps) allPathsCanonical -updateSandboxTimestampsFile _ _ _ _ _ = return () +updateSandboxTimestampsFile _ _ _ _ _ _ = return () -- ------------------------------------------------------------ -- * Actually do the installations @@ -1081,7 +1062,7 @@ performInstallations :: Verbosity -> InstallArgs -> InstalledPackageIndex -> InstallPlan - -> IO InstallPlan + -> IO BuildResults performInstallations verbosity (packageDBs, repoCtxt, comp, platform, conf, useSandbox, _, globalFlags, configFlags, configExFlags, installFlags, haddockFlags) @@ -1189,71 +1170,21 @@ performInstallations verbosity executeInstallPlan :: Verbosity - -> JobControl IO (PackageId, UnitId, BuildResult) + -> JobControl IO (UnitId, BuildResult) -> Bool -> UseLogFile -> InstallPlan -> (ReadyPackage -> IO BuildResult) - -> IO InstallPlan + -> IO BuildResults executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = - tryNewTasks False False plan0 - where - tryNewTasks :: Bool -> Bool -> InstallPlan -> IO InstallPlan - tryNewTasks tasksFailed tasksRemaining plan - | tasksFailed && not keepGoing && not tasksRemaining - = return plan - - | tasksFailed && not keepGoing && tasksRemaining - = waitForTasks tasksFailed plan - - tryNewTasks tasksFailed tasksRemaining plan = do - case InstallPlan.ready plan of - [] | not tasksRemaining -> return plan - | otherwise -> waitForTasks tasksFailed plan - pkgs -> do - sequence_ - [ do info verbosity $ "Ready to install " ++ display pkgid - spawnJob jobCtl $ do - buildResult <- installPkg pkg - return (packageId pkg, installedPackageId pkg, buildResult) - | pkg <- pkgs - , let pkgid = packageId pkg ] - - let plan' = InstallPlan.processing pkgs plan - waitForTasks tasksFailed plan' - - waitForTasks :: Bool -> InstallPlan -> IO InstallPlan - waitForTasks tasksFailed plan = do - info verbosity $ "Waiting for install task to finish..." - (pkgid, ipid, buildResult) <- collectJob jobCtl - printBuildResult pkgid ipid buildResult - let plan' = updatePlan pkgid ipid buildResult plan - tasksFailed' = tasksFailed || isBuildFailure buildResult - -- if this is the first failure and we're not trying to keep going - -- then try to cancel as many of the remaining jobs as possible - when (not tasksFailed && isBuildFailure buildResult && not keepGoing) $ - cancelJobs jobCtl - tasksRemaining <- remainingJobs jobCtl - tryNewTasks tasksFailed' tasksRemaining plan' - - isBuildFailure (Left _buildFailure) = True - isBuildFailure (Right _buildSuccess) = False - - updatePlan :: PackageIdentifier -> InstalledPackageId - -> BuildResult -> InstallPlan - -> InstallPlan - updatePlan _pkgid ipid (Right buildSuccess@(BuildOk _ _ ipkgs)) = - InstallPlan.completed ipid - (find (\ipkg -> installedPackageId ipkg == ipid) ipkgs) buildSuccess + InstallPlan.execute + jobCtl keepGoing depsFailure plan0 $ \pkg -> do + buildResult <- installPkg pkg + printBuildResult (packageId pkg) (installedPackageId pkg) buildResult + return buildResult - updatePlan pkgid ipid (Left buildFailure) = - InstallPlan.failed ipid buildFailure depsFailure - where - depsFailure = DependentFailed pkgid - -- So this first pkgid failed for whatever reason (buildFailure). - -- All the other packages that depended on this pkgid, which we - -- now cannot build, we mark as failing due to 'DependentFailed' - -- which kind of means it was not their fault. + where + depsFailure = DependentFailed . packageId -- Print build log if something went wrong, and 'Installed $PKGID' -- otherwise. diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs index 01e71bfd426..da1b0f4ae01 100644 --- a/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal-install/Distribution/Client/InstallPlan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} @@ -27,15 +28,22 @@ module Distribution.Client.InstallPlan ( fromSolverInstallPlan, configureInstallPlan, + remove, + preexisting, + -- * Traversal + executionOrder, + execute, + BuildResults, + lookupBuildResult, + -- ** Traversal helpers + -- $traversal + Processing, ready, - processing, completed, failed, - remove, - preexisting, - preinstalled, + -- * Display showPlanIndex, showInstallPlan, @@ -43,7 +51,7 @@ module Distribution.Client.InstallPlan ( reverseTopologicalOrder, ) where -import Distribution.Client.Types +import Distribution.Client.Types hiding (BuildResults) import qualified Distribution.PackageDescription as PD import qualified Distribution.Simple.Configure as Configure import qualified Distribution.Simple.Setup as Cabal @@ -54,12 +62,12 @@ import Distribution.Package ( PackageIdentifier(..), Package(..) , HasUnitId(..), UnitId(..) ) import Distribution.Solver.Types.SolverPackage +import Distribution.Client.JobControl import Distribution.Text ( display ) import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan) -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.PackageFixedDeps import Distribution.Solver.Types.Settings @@ -71,15 +79,18 @@ import Distribution.Solver.Types.SolverId import Data.List ( foldl', intercalate ) import Data.Maybe - ( catMaybes ) + ( fromMaybe, catMaybes, isJust ) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..)) import Distribution.Compat.Binary (Binary(..)) import GHC.Generics +import Control.Monad import Control.Exception ( assert ) import qualified Data.Map as Map -import qualified Data.Traversable as T +import Data.Map (Map) +import qualified Data.Set as Set +import Data.Set (Set) -- When cabal tries to install a number of packages, including all their @@ -135,81 +146,65 @@ import qualified Data.Traversable as T -- dependencies; if we give a 'PackageInstalled' instance it would be too easy -- to get this wrong (and, for instance, call graph traversal functions from -- Cabal rather than from cabal-install). Instead, see 'PackageFixedDeps'. -data GenericPlanPackage ipkg srcpkg iresult ifailure +data GenericPlanPackage ipkg srcpkg = PreExisting ipkg | Configured srcpkg - | Processing (GenericReadyPackage srcpkg) - | Installed (GenericReadyPackage srcpkg) (Maybe ipkg) iresult - | Failed srcpkg ifailure deriving (Eq, Show, Generic) instance (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) - => IsNode (GenericPlanPackage ipkg srcpkg iresult ifailure) where - type Key (GenericPlanPackage ipkg srcpkg iresult ifailure) = UnitId -- TODO: change me + => IsNode (GenericPlanPackage ipkg srcpkg) where + type Key (GenericPlanPackage ipkg srcpkg) = UnitId -- TODO: change me nodeKey = installedUnitId nodeNeighbors = CD.flatDeps . depends -instance (Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure) - => Binary (GenericPlanPackage ipkg srcpkg iresult ifailure) +instance (Binary ipkg, Binary srcpkg) + => Binary (GenericPlanPackage ipkg srcpkg) type PlanPackage = GenericPlanPackage InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) - BuildSuccess BuildFailure instance (Package ipkg, Package srcpkg) => - Package (GenericPlanPackage ipkg srcpkg iresult ifailure) where + Package (GenericPlanPackage ipkg srcpkg) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg - packageId (Processing rpkg) = packageId rpkg - packageId (Installed rpkg _ _) = packageId rpkg - packageId (Failed spkg _) = packageId spkg instance (PackageFixedDeps srcpkg, PackageFixedDeps ipkg) => - PackageFixedDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) where + PackageFixedDeps (GenericPlanPackage ipkg srcpkg) where depends (PreExisting pkg) = depends pkg depends (Configured pkg) = depends pkg - depends (Processing pkg) = depends pkg - depends (Installed pkg _ _) = depends pkg - depends (Failed pkg _) = depends pkg instance (HasUnitId ipkg, HasUnitId srcpkg) => HasUnitId - (GenericPlanPackage ipkg srcpkg iresult ifailure) where - installedUnitId (PreExisting ipkg ) = installedUnitId ipkg - installedUnitId (Configured spkg) = installedUnitId spkg - installedUnitId (Processing rpkg) = installedUnitId rpkg - -- NB: defer to the actual installed package info in this case - installedUnitId (Installed _ (Just ipkg) _) = installedUnitId ipkg - installedUnitId (Installed rpkg _ _) = installedUnitId rpkg - installedUnitId (Failed spkg _) = installedUnitId spkg - -data GenericInstallPlan ipkg srcpkg iresult ifailure = GenericInstallPlan { - planIndex :: !(PlanIndex ipkg srcpkg iresult ifailure), + (GenericPlanPackage ipkg srcpkg) where + installedUnitId (PreExisting ipkg) = installedUnitId ipkg + installedUnitId (Configured spkg) = installedUnitId spkg + +data GenericInstallPlan ipkg srcpkg = GenericInstallPlan { + planIndex :: !(PlanIndex ipkg srcpkg), planIndepGoals :: !IndependentGoals } -- | 'GenericInstallPlan' specialised to most commonly used types. type InstallPlan = GenericInstallPlan InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc) - BuildSuccess BuildFailure -type PlanIndex ipkg srcpkg iresult ifailure = - Graph (GenericPlanPackage ipkg srcpkg iresult ifailure) +type PlanIndex ipkg srcpkg = + Graph (GenericPlanPackage ipkg srcpkg) invariant :: (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure -> Bool + => GenericInstallPlan ipkg srcpkg -> Bool invariant plan = valid (planIndepGoals plan) (planIndex plan) -- | Smart constructor that deals with caching the 'Graph' representation. -- -mkInstallPlan :: PlanIndex ipkg srcpkg iresult ifailure +mkInstallPlan :: PlanIndex ipkg srcpkg -> IndependentGoals - -> GenericInstallPlan ipkg srcpkg iresult ifailure + -> GenericInstallPlan ipkg srcpkg mkInstallPlan index indepGoals = GenericInstallPlan { planIndex = index, @@ -221,8 +216,8 @@ internalError msg = error $ "InstallPlan: internal error: " ++ msg instance (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg, - Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure) - => Binary (GenericInstallPlan ipkg srcpkg iresult ifailure) where + Binary ipkg, Binary srcpkg) + => Binary (GenericInstallPlan ipkg srcpkg) where put GenericInstallPlan { planIndex = index, planIndepGoals = indepGoals @@ -233,7 +228,7 @@ instance (HasUnitId ipkg, PackageFixedDeps ipkg, return $! mkInstallPlan index indepGoals showPlanIndex :: (HasUnitId ipkg, HasUnitId srcpkg) - => PlanIndex ipkg srcpkg iresult ifailure -> String + => PlanIndex ipkg srcpkg -> String showPlanIndex index = intercalate "\n" (map showPlanPackage (Graph.toList index)) where showPlanPackage p = @@ -242,31 +237,28 @@ showPlanIndex index = ++ display (installedUnitId p) ++ ")" showInstallPlan :: (HasUnitId ipkg, HasUnitId srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure -> String + => GenericInstallPlan ipkg srcpkg -> String showInstallPlan = showPlanIndex . planIndex -showPlanPackageTag :: GenericPlanPackage ipkg srcpkg iresult ifailure -> String +showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String showPlanPackageTag (PreExisting _) = "PreExisting" showPlanPackageTag (Configured _) = "Configured" -showPlanPackageTag (Processing _) = "Processing" -showPlanPackageTag (Installed _ _ _) = "Installed" -showPlanPackageTag (Failed _ _) = "Failed" -- | Build an installation plan from a valid set of resolved packages. -- new :: (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) => IndependentGoals - -> PlanIndex ipkg srcpkg iresult ifailure - -> Either [PlanProblem ipkg srcpkg iresult ifailure] - (GenericInstallPlan ipkg srcpkg iresult ifailure) + -> PlanIndex ipkg srcpkg + -> Either [PlanProblem ipkg srcpkg] + (GenericInstallPlan ipkg srcpkg) new indepGoals index = case problems indepGoals index of [] -> Right (mkInstallPlan index indepGoals) probs -> Left probs -toList :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] +toList :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] toList = Graph.toList . planIndex -- | Remove packages from the install plan. This will result in an @@ -277,167 +269,16 @@ toList = Graph.toList . planIndex -- remove :: (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) - => (GenericPlanPackage ipkg srcpkg iresult ifailure -> Bool) - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> Either [PlanProblem ipkg srcpkg iresult ifailure] - (GenericInstallPlan ipkg srcpkg iresult ifailure) + => (GenericPlanPackage ipkg srcpkg -> Bool) + -> GenericInstallPlan ipkg srcpkg + -> Either [PlanProblem ipkg srcpkg] + (GenericInstallPlan ipkg srcpkg) remove shouldRemove plan = new (planIndepGoals plan) newIndex where newIndex = Graph.fromList $ filter (not . shouldRemove) (toList plan) --- | The packages that are ready to be installed. That is they are in the --- configured state and have all their dependencies installed already. --- The plan is complete if the result is @[]@. --- -ready :: forall ipkg srcpkg iresult ifailure. - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericReadyPackage srcpkg] -ready plan = assert check readyPackages - where - check = if null readyPackages && null processingPackages - then null configuredPackages - else True - configuredPackages = [ pkg | Configured pkg <- toList plan ] - processingPackages = [ pkg | Processing pkg <- toList plan] - - readyPackages :: [GenericReadyPackage srcpkg] - readyPackages = catMaybes (map (lookupReadyPackage plan) configuredPackages) - -lookupReadyPackage :: forall ipkg srcpkg iresult ifailure. - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> srcpkg - -> Maybe (GenericReadyPackage srcpkg) -lookupReadyPackage plan pkg = do - _ <- hasAllInstalledDeps pkg - return (ReadyPackage pkg) - where - - hasAllInstalledDeps :: srcpkg -> Maybe (ComponentDeps [ipkg]) - hasAllInstalledDeps = T.mapM (mapM isInstalledDep) . depends - - isInstalledDep :: UnitId -> Maybe ipkg - isInstalledDep pkgid = - case Graph.lookup pkgid (planIndex plan) of - Just (PreExisting ipkg) -> Just ipkg - Just (Configured _) -> Nothing - Just (Processing _) -> Nothing - Just (Installed _ (Just ipkg) _) -> Just ipkg - Just (Installed _ Nothing _) -> internalError (depOnNonLib pkgid) - Just (Failed _ _) -> internalError depOnFailed - Nothing -> internalError incomplete - incomplete = "install plan is not closed" - depOnFailed = "configured package depends on failed package" - depOnNonLib dep = "the configured package " - ++ display (packageId pkg) - ++ " depends on a non-library package " - ++ display dep - --- | Marks packages in the graph as currently processing (e.g. building). --- --- * The package must exist in the graph and be in the configured state. --- -processing :: forall ipkg srcpkg iresult ifailure. - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => [GenericReadyPackage srcpkg] - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -processing pkgs plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = Graph.unionRight (planIndex plan) processingPkgs - } - processingPkgs :: PlanIndex ipkg srcpkg iresult ifailure - processingPkgs = Graph.fromList [Processing pkg | pkg <- pkgs] - --- | Marks a package in the graph as completed. Also saves the build result for --- the completed package in the plan. --- --- * The package must exist in the graph and be in the processing state. --- * The package must have had no uninstalled dependent packages. --- -completed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId - -> Maybe ipkg -> iresult - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -completed pkgid mipkg buildResult plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = Graph.insert installed - . Graph.deleteKey pkgid - $ planIndex plan - } - installed = Installed (lookupProcessingPackage plan pkgid) mipkg buildResult - --- | Marks a package in the graph as having failed. It also marks all the --- packages that depended on it as having failed. --- --- * The package must exist in the graph and be in the processing --- state. --- -failed :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId -- ^ The id of the package that failed to install - -> ifailure -- ^ The build result to use for the failed package - -> ifailure -- ^ The build result to use for its dependencies - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' - where - -- NB: failures don't update IPIDs - plan' = plan { - planIndex = Graph.unionRight (planIndex plan) failures - } - ReadyPackage srcpkg = lookupProcessingPackage plan pkgid - failures = Graph.fromList - $ Failed srcpkg buildResult - : [ Failed pkg' buildResult' - | Just pkg' <- map checkConfiguredPackage - $ packagesThatDependOn plan pkgid ] - --- | Lookup the reachable packages in the reverse dependency graph. --- Does NOT include the package for @pkgid@! --- -packagesThatDependOn :: (HasUnitId ipkg, HasUnitId srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> UnitId - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] -packagesThatDependOn plan pkgid = filter ((/= pkgid) . installedUnitId) - $ case Graph.revClosure (planIndex plan) [pkgid] of - Nothing -> [] - Just r -> r - --- | Lookup a package that we expect to be in the processing state. --- -lookupProcessingPackage :: (PackageFixedDeps ipkg, PackageFixedDeps srcpkg, - HasUnitId ipkg, HasUnitId srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> UnitId - -> GenericReadyPackage srcpkg -lookupProcessingPackage plan pkgid = - case Graph.lookup pkgid (planIndex plan) of - Just (Processing pkg) -> pkg - _ -> internalError $ "not in processing state or no such pkg " ++ - display pkgid - --- | Check a package that we expect to be in the configured or failed state. --- -checkConfiguredPackage :: (Package srcpkg, Package ipkg) - => GenericPlanPackage ipkg srcpkg iresult ifailure - -> Maybe srcpkg -checkConfiguredPackage (Configured pkg) = Just pkg -checkConfiguredPackage (Failed _ _) = Nothing -checkConfiguredPackage pkg = - internalError $ "not configured or no such pkg " ++ display (packageId pkg) - -- | Replace a ready package with a pre-existing one. The pre-existing one -- must have exactly the same dependencies as the source one was configured -- with. @@ -446,8 +287,8 @@ preexisting :: (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) => UnitId -> ipkg - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure + -> GenericInstallPlan ipkg srcpkg + -> GenericInstallPlan ipkg srcpkg preexisting pkgid ipkg plan = assert (invariant plan') plan' where plan' = plan { @@ -458,24 +299,6 @@ preexisting pkgid ipkg plan = assert (invariant plan') plan' $ planIndex plan } --- | Replace a ready package with an installed one. The installed one --- must have exactly the same dependencies as the source one was configured --- with. --- -preinstalled :: (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => UnitId - -> Maybe ipkg -> iresult - -> GenericInstallPlan ipkg srcpkg iresult ifailure - -> GenericInstallPlan ipkg srcpkg iresult ifailure -preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan' - where - plan' = plan { planIndex = Graph.insert installed (planIndex plan) } - Just installed = do - Configured pkg <- Graph.lookup pkgid (planIndex plan) - rpkg <- lookupReadyPackage plan pkg - return (Installed rpkg mipkg buildResult) - -- ------------------------------------------------------------ -- * Checking validity of plans @@ -490,17 +313,17 @@ preinstalled pkgid mipkg buildResult plan = assert (invariant plan') plan' valid :: (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) => IndependentGoals - -> PlanIndex ipkg srcpkg iresult ifailure + -> PlanIndex ipkg srcpkg -> Bool valid indepGoals index = null $ problems indepGoals index -data PlanProblem ipkg srcpkg iresult ifailure = - PackageMissingDeps (GenericPlanPackage ipkg srcpkg iresult ifailure) +data PlanProblem ipkg srcpkg = + PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [PackageIdentifier] - | PackageCycle [GenericPlanPackage ipkg srcpkg iresult ifailure] - | PackageStateInvalid (GenericPlanPackage ipkg srcpkg iresult ifailure) - (GenericPlanPackage ipkg srcpkg iresult ifailure) + | PackageCycle [GenericPlanPackage ipkg srcpkg] + | PackageStateInvalid (GenericPlanPackage ipkg srcpkg) + (GenericPlanPackage ipkg srcpkg) -- | For an invalid plan, produce a detailed list of problems as human readable -- error messages. This is mainly intended for debugging purposes. @@ -509,8 +332,8 @@ data PlanProblem ipkg srcpkg iresult ifailure = problems :: (HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) => IndependentGoals - -> PlanIndex ipkg srcpkg iresult ifailure - -> [PlanProblem ipkg srcpkg iresult ifailure] + -> PlanIndex ipkg srcpkg + -> [PlanProblem ipkg srcpkg] problems _indepGoals index = [ PackageMissingDeps pkg @@ -529,42 +352,32 @@ problems _indepGoals index = (CD.flatDeps (depends pkg)) , not (stateDependencyRelation pkg pkg') ] + -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on -- package @b@ we require that @dependencyStatesOk a b = True@. -- -stateDependencyRelation :: GenericPlanPackage ipkg srcpkg iresult ifailure - -> GenericPlanPackage ipkg srcpkg iresult ifailure +stateDependencyRelation :: GenericPlanPackage ipkg srcpkg + -> GenericPlanPackage ipkg srcpkg -> Bool -stateDependencyRelation (PreExisting _) (PreExisting _) = True - -stateDependencyRelation (Configured _) (PreExisting _) = True -stateDependencyRelation (Configured _) (Configured _) = True -stateDependencyRelation (Configured _) (Processing _) = True -stateDependencyRelation (Configured _) (Installed _ _ _) = True - -stateDependencyRelation (Processing _) (PreExisting _) = True -stateDependencyRelation (Processing _) (Installed _ _ _) = True - -stateDependencyRelation (Installed _ _ _) (PreExisting _) = True -stateDependencyRelation (Installed _ _ _) (Installed _ _ _) = True - -stateDependencyRelation (Failed _ _) (PreExisting _) = True --- failed can depends on configured because a package can depend on --- several other packages and if one of the deps fail then we fail --- but we still depend on the other ones that did not fail: -stateDependencyRelation (Failed _ _) (Configured _) = True -stateDependencyRelation (Failed _ _) (Processing _) = True -stateDependencyRelation (Failed _ _) (Installed _ _ _) = True -stateDependencyRelation (Failed _ _) (Failed _ _) = True +stateDependencyRelation (PreExisting _) (PreExisting _) = True +stateDependencyRelation (Configured _) (PreExisting _) = True +stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation (PreExisting _) (Configured _) = False -stateDependencyRelation _ _ = False - -reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg iresult ifailure - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] +-- | Return all the packages in the 'InstallPlan' in reverse topological order. +-- That is, for each package, all depencencies of the package appear first. +-- +-- Compared to 'executionOrder', this function returns all the installed and +-- source packages rather than just the source ones. Also, while both this +-- and 'executionOrder' produce reverse topological orderings of the package +-- dependency graph, it is not necessarily exactly the same order. +-- +reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg + -> [GenericPlanPackage ipkg srcpkg] reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan) @@ -574,9 +387,9 @@ fromSolverInstallPlan :: -- Maybe this should be a UnitId not ConfiguredId? => ( (SolverId -> ConfiguredId) -> SolverInstallPlan.SolverPlanPackage - -> GenericPlanPackage ipkg srcpkg iresult ifailure ) + -> GenericPlanPackage ipkg srcpkg) -> SolverInstallPlan - -> GenericInstallPlan ipkg srcpkg iresult ifailure + -> GenericInstallPlan ipkg srcpkg fromSolverInstallPlan f plan = mkInstallPlan (Graph.fromList pkgs') (SolverInstallPlan.planIndepGoals plan) @@ -641,3 +454,314 @@ configureInstallPlan solverPlan = } where deps = fmap (map mapDep) (solverPkgDeps spkg) + + +-- ------------------------------------------------------------ +-- * Primitives for traversing plans +-- ------------------------------------------------------------ + +-- $traversal +-- +-- Algorithms to traverse or execute an 'InstallPlan', especially in parallel, +-- may make use of the 'Processing' type and the associated operations +-- 'ready', 'completed' and 'failed'. +-- +-- The 'Processing' type is used to keep track of the state of a traversal and +-- includes the set of packages that are in the processing state, e.g. in the +-- process of being installed, plus those that have been completed and those +-- where processing failed. +-- +-- Traversal algorithms start with an 'InstallPlan': +-- +-- * Initially there will be certain packages that can be processed immediately +-- (since they are configured source packages and have all their dependencies +-- installed already). The function 'ready' returns these packages plus a +-- 'Processing' state that marks these same packages as being in the +-- processing state. +-- +-- * The algorithm must now arrange for these packages to be processed +-- (possibly in parallel). When a package has completed processing, the +-- algorithm needs to know which other packages (if any) are now ready to +-- process as a result. The 'completed' function marks a package as completed +-- and returns any packages that are newly in the processing state (ie ready +-- to process), along with the updated 'Processing' state. +-- +-- * If failure is possible then when processing a package fails, the algorithm +-- needs to know which other packages have also failed as a result. The +-- 'failed' function marks the given package as failed as well as all the +-- other packages that depend on the failed package. In addition it returns +-- the other failed packages. + + +-- | The 'Processing' type is used to keep track of the state of a traversal +-- and includes the set of packages that are in the processing state, e.g. in +-- the process of being installed, plus those that have been completed and +-- those where processing failed. +-- +data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId) + -- processing, completed, failed + +-- | The packages in the plan that are initially ready to be installed. +-- That is they are in the configured state and have all their dependencies +-- installed already. +-- +-- The result is both the packages that are now ready to be installed and also +-- a 'Processing' state containing those same packages. The assumption is that +-- all the packages that are ready will now be processed and so we can consider +-- them to be in the processing state. +-- +ready :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => GenericInstallPlan ipkg srcpkg + -> ([GenericReadyPackage srcpkg], Processing) +ready plan = + assert (processingInvariant plan processing) $ + (readyPackages, processing) + where + !processing = + Processing + (Set.fromList [ installedUnitId pkg | pkg <- readyPackages ]) + (Set.fromList [ installedUnitId pkg | PreExisting pkg <- toList plan ]) + Set.empty + readyPackages = + [ ReadyPackage pkg + | Configured pkg <- toList plan + , all isPreExisting (directDeps plan (installedUnitId pkg)) + ] + + isPreExisting (PreExisting {}) = True + isPreExisting _ = False + + +-- | Given a package in the processing state, mark the package as completed +-- and return any packages that are newly in the processing state (ie ready to +-- process), along with the updated 'Processing' state. +-- +completed :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([GenericReadyPackage srcpkg], Processing) +completed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (processingInvariant plan processing') $ + + ( map asReadyPackage newlyReady + , processing' ) + where + completedSet' = Set.insert pkgid completedSet + + -- each direct reverse dep where all direct deps are completed + newlyReady = [ dep + | dep <- revDirectDeps plan pkgid + , all ((`Set.member` completedSet') . installedUnitId) + (directDeps plan (installedUnitId dep)) + ] + + processingSet' = foldl' (flip Set.insert) + (Set.delete pkgid processingSet) + (map installedUnitId newlyReady) + processing' = Processing processingSet' completedSet' failedSet + + asReadyPackage (Configured pkg) = ReadyPackage pkg + asReadyPackage _ = error "InstallPlan.completed: internal error" + +failed :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> UnitId + -> ([srcpkg], Processing) +failed plan (Processing processingSet completedSet failedSet) pkgid = + assert (pkgid `Set.member` processingSet) $ + assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $ + assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $ + assert (all (`Set.notMember` failedSet) (tail newlyFailedIds)) $ + assert (processingInvariant plan processing') $ + + ( map asConfiguredPackage (tail newlyFailed) + , processing' ) + where + processingSet' = Set.delete pkgid processingSet + failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds + newlyFailedIds = map installedUnitId newlyFailed + newlyFailed = fromMaybe (internalError "package not in graph") + $ Graph.revClosure (planIndex plan) [pkgid] + processing' = Processing processingSet' completedSet failedSet' + + asConfiguredPackage (Configured pkg) = pkg + asConfiguredPackage _ = internalError "not in configured state" + +directDeps, revDirectDeps + :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => GenericInstallPlan ipkg srcpkg + -> UnitId + -> [GenericPlanPackage ipkg srcpkg] + +directDeps plan pkgid = + case Graph.neighbors (planIndex plan) pkgid of + Just deps -> deps + Nothing -> internalError "directDeps: package not in graph" + +revDirectDeps plan pkgid = + case Graph.revNeighbors (planIndex plan) pkgid of + Just deps -> deps + Nothing -> internalError "directDeps: package not in graph" + +processingInvariant :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => GenericInstallPlan ipkg srcpkg + -> Processing -> Bool +processingInvariant plan (Processing processingSet completedSet failedSet) = + all (isJust . flip Graph.lookup (planIndex plan)) (Set.toList processingSet) + && all (isJust . flip Graph.lookup (planIndex plan)) (Set.toList completedSet) + && all (isJust . flip Graph.lookup (planIndex plan)) (Set.toList failedSet) + && noIntersection processingSet completedSet + && noIntersection processingSet failedSet + && noIntersection failedSet completedSet + && noIntersection processingClosure completedSet + && noIntersection processingClosure failedSet + && and [ case Graph.lookup pkgid (planIndex plan) of + Just (Configured _) -> True + Just (PreExisting _) -> False + Nothing -> False + | pkgid <- Set.toList processingSet ++ Set.toList failedSet ] + where + processingClosure = Set.fromList + . map installedUnitId + . fromMaybe (internalError "processingClosure") + . Graph.revClosure (planIndex plan) + . Set.toList + $ processingSet + noIntersection a b = Set.null (Set.intersection a b) + + +-- ------------------------------------------------------------ +-- * Traversing plans +-- ------------------------------------------------------------ + +-- | Flatten an 'InstallPlan', producing the sequence of source packages in +-- the order in which they would be processed when the plan is executed. This +-- can be used for simultations or presenting execution dry-runs. +-- +-- It is guaranteed to give the same order as using 'execute' (with a serial +-- in-order 'JobControl'), which is a reverse topological orderings of the +-- source packages in the dependency graph, albeit not necessarily exactly the +-- same ordering as that produced by 'reverseTopologicalOrder'. +-- +executionOrder :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => GenericInstallPlan ipkg srcpkg + -> [GenericReadyPackage srcpkg] +executionOrder plan = + let (newpkgs, processing) = ready plan + in tryNewTasks processing newpkgs + where + tryNewTasks _processing [] = [] + tryNewTasks processing (p:todo) = waitForTasks processing p todo + + waitForTasks processing p todo = + p : tryNewTasks processing' (todo++nextpkgs) + where + (nextpkgs, processing') = completed plan processing (installedUnitId p) + + +-- ------------------------------------------------------------ +-- * Executing plans +-- ------------------------------------------------------------ + +-- | The set of results we get from executing an install plan. +-- +type BuildResults failure result = Map UnitId (Either failure result) + +-- | Lookup the build result for a single package. +-- +lookupBuildResult :: HasUnitId pkg + => pkg -> BuildResults failure result + -> Maybe (Either failure result) +lookupBuildResult = Map.lookup . installedUnitId + +-- | Execute an install plan. This traverses the plan in dependency order. +-- +-- Executing each individual package can fail and if so all dependents fail +-- too. The result for each package is collected as a 'BuildResults' map. +-- +-- Visiting each package happens with optional parallelism, as determined by +-- the 'JobControl'. By default, after any failure we stop as soon as possible +-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour +-- can be reversed to keep going and build as many packages as possible. +-- +execute :: forall m ipkg srcpkg result failure. + (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg, + Monad m) + => JobControl m (UnitId, Either failure result) + -> Bool -- ^ Keep going after failure + -> (srcpkg -> failure) -- ^ Value for dependents of failed packages + -> GenericInstallPlan ipkg srcpkg + -> (GenericReadyPackage srcpkg -> m (Either failure result)) + -> m (BuildResults failure result) +execute jobCtl keepGoing depFailure plan installPkg = + let (newpkgs, processing) = ready plan + in tryNewTasks Map.empty False False processing newpkgs + where + tryNewTasks :: BuildResults failure result + -> Bool -> Bool -> Processing + -> [GenericReadyPackage srcpkg] + -> m (BuildResults failure result) + + tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs + -- we were in the process of cancelling and now we're finished + | tasksFailed && not keepGoing && not tasksRemaining + = return results + + -- we are still in the process of cancelling, wait for remaining tasks + | tasksFailed && not keepGoing && tasksRemaining + = waitForTasks results tasksFailed processing + + -- no new tasks to do and all tasks are done so we're finished + | null newpkgs && not tasksRemaining + = return results + + -- no new tasks to do, remaining tasks to wait for + | null newpkgs + = waitForTasks results tasksFailed processing + + -- new tasks to do, spawn them, then wait for tasks to complete + | otherwise + = do sequence_ [ spawnJob jobCtl $ do + result <- installPkg pkg + return (installedUnitId pkg, result) + | pkg <- newpkgs ] + waitForTasks results tasksFailed processing + + waitForTasks :: BuildResults failure result + -> Bool -> Processing + -> m (BuildResults failure result) + waitForTasks !results tasksFailed !processing = do + (pkgid, result) <- collectJob jobCtl + + case result of + + Right _success -> do + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' tasksFailed tasksRemaining + processing' nextpkgs + where + results' = Map.insert pkgid result results + (nextpkgs, processing') = completed plan processing pkgid + + Left _failure -> do + -- if this is the first failure and we're not trying to keep going + -- then try to cancel as many of the remaining jobs as possible + when (not tasksFailed && not keepGoing) $ + cancelJobs jobCtl + + tasksRemaining <- remainingJobs jobCtl + tryNewTasks results' True tasksRemaining processing' [] + where + (depsfailed, processing') = failed plan processing pkgid + results' = Map.insert pkgid result results `Map.union` depResults + depResults = Map.fromList + [ (installedUnitId deppkg, Left (depFailure deppkg)) + | deppkg <- depsfailed ] diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs index 692c4e25e49..f74ebcfbad9 100644 --- a/cabal-install/Distribution/Client/InstallSymlink.hs +++ b/cabal-install/Distribution/Client/InstallSymlink.hs @@ -20,6 +20,7 @@ module Distribution.Client.InstallSymlink ( import Distribution.Package (PackageIdentifier) import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types (BuildResults) import Distribution.Client.Setup (InstallFlags) import Distribution.Simple.Setup (ConfigFlags) import Distribution.Simple.Compiler @@ -28,9 +29,10 @@ import Distribution.System symlinkBinaries :: Platform -> Compiler -> ConfigFlags -> InstallFlags - -> InstallPlan + -> InstallPlan + -> BuildResults -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries _ _ _ _ _ = return [] +symlinkBinaries _ _ _ _ _ _ = return [] symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" @@ -38,8 +40,7 @@ symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" #else import Distribution.Client.Types - ( GenericReadyPackage(..), ReadyPackage - , ConfiguredPackage(..)) + ( ConfiguredPackage(..), BuildResults ) import Distribution.Client.Setup ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -106,8 +107,9 @@ symlinkBinaries :: Platform -> Compiler -> ConfigFlags -> InstallFlags -> InstallPlan + -> BuildResults -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries platform comp configFlags installFlags plan = +symlinkBinaries platform comp configFlags installFlags plan buildResults = case flagToMaybe (installSymlinkBinDir installFlags) of Nothing -> return [] Just symlinkBinDir @@ -136,15 +138,17 @@ symlinkBinaries platform comp configFlags installFlags plan = where exes = [ (cpkg, pkg, exe) - | InstallPlan.Installed cpkg _ _ <- InstallPlan.toList plan - , let pkg = pkgDescription cpkg + | InstallPlan.Configured cpkg <- InstallPlan.toList plan + , case InstallPlan.lookupBuildResult cpkg buildResults of + Just (Right _success) -> True + _ -> False + , let pkg :: PackageDescription + pkg = pkgDescription cpkg , exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) ] - pkgDescription :: ReadyPackage -> PackageDescription - pkgDescription (ReadyPackage (ConfiguredPackage - _ (SourcePackage _ pkg _ _) - flags stanzas _)) = + pkgDescription (ConfiguredPackage _ (SourcePackage _ pkg _ _) + flags stanzas _) = case finalizePD flags (enableStanzas stanzas) (const True) platform cinfo [] pkg of diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index b1697da9b70..bbeb7385d26 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/Distribution/Client/ProjectBuilding.hs @@ -262,12 +262,6 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do Just (RepoTarballPackage _ _ tarball) -> dryRunTarballPkg pkg depsBuildStatus tarball - dryRunPkg (InstallPlan.Processing {}) _ = unexpectedState - dryRunPkg (InstallPlan.Installed {}) _ = unexpectedState - dryRunPkg (InstallPlan.Failed {}) _ = unexpectedState - - unexpectedState = error "rebuildTargetsDryRun: unexpected package state" - dryRunTarballPkg :: ElaboratedConfiguredPackage -> ComponentDeps [BuildStatus] -> FilePath @@ -315,19 +309,19 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do -- depencencies. This can be used to propagate information from depencencies. -- foldMInstallPlanDepOrder - :: forall m ipkg srcpkg iresult ifailure b. + :: forall m ipkg srcpkg b. (Monad m, HasUnitId ipkg, PackageFixedDeps ipkg, HasUnitId srcpkg, PackageFixedDeps srcpkg) - => GenericInstallPlan ipkg srcpkg iresult ifailure - -> (GenericPlanPackage ipkg srcpkg iresult ifailure -> + => GenericInstallPlan ipkg srcpkg + -> (GenericPlanPackage ipkg srcpkg -> ComponentDeps [b] -> m b) -> m (Map InstalledPackageId b) foldMInstallPlanDepOrder plan0 visit = go Map.empty (InstallPlan.reverseTopologicalOrder plan0) where go :: Map InstalledPackageId b - -> [GenericPlanPackage ipkg srcpkg iresult ifailure] + -> [GenericPlanPackage ipkg srcpkg] -> m (Map InstalledPackageId b) go !results [] = return results @@ -346,20 +340,22 @@ improveInstallPlanWithUpToDatePackages :: ElaboratedInstallPlan -> BuildStatusMap -> ElaboratedInstallPlan improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus = - replaceWithPreInstalled installPlan - [ (installedPackageId pkg, ipkgs, buildSuccess) + replaceWithPrePreExisting installPlan + [ (installedPackageId pkg, ipkgs) | InstallPlan.Configured pkg <- InstallPlan.reverseTopologicalOrder installPlan , let ipkgid = installedPackageId pkg Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus - , BuildStatusUpToDate ipkgs buildSuccess <- [pkgBuildStatus] + , BuildStatusUpToDate ipkgs _buildSuccess <- [pkgBuildStatus] ] where - replaceWithPreInstalled = - foldl' (\plan (ipkgid, ipkgs, buildSuccess) -> - InstallPlan.preinstalled ipkgid - (find (\ipkg -> installedPackageId ipkg == ipkgid) ipkgs) - buildSuccess plan) + replaceWithPrePreExisting = + foldl' (\plan (ipkgid, ipkgs) -> + case find (\ipkg -> installedPackageId ipkg == ipkgid) ipkgs of + Just ipkg -> InstallPlan.preexisting ipkgid ipkg plan + Nothing -> unexpected) + unexpected = + error "improveInstallPlanWithUpToDatePackages: dep on non lib package" ----------------------------- @@ -571,7 +567,7 @@ rebuildTargets :: Verbosity -> ElaboratedSharedConfig -> BuildStatusMap -> BuildTimeSettings - -> IO ElaboratedInstallPlan + -> IO BuildResults rebuildTargets verbosity distDirLayout@DistDirLayout{..} installPlan @@ -604,7 +600,10 @@ rebuildTargets verbosity installPlan pkgsBuildStatus $ \downloadMap -> -- For each package in the plan, in dependency order, but in parallel... - executeInstallPlan verbosity jobControl keepGoing installPlan $ \pkg -> + InstallPlan.execute jobControl keepGoing (DependentFailed . packageId) + installPlan $ \pkg -> + fmap (\x -> case x of BuildFailure f -> Left f + BuildSuccess _ s -> Right s) $ handle (return . BuildFailure) $ --TODO: review exception handling let ipkgid = installedPackageId pkg @@ -792,94 +791,6 @@ waitAsyncPackageDownload verbosity downloadMap pkg = fail "waitAsyncPackageDownload: package not being download" -executeInstallPlan - :: forall ipkg srcpkg iresult. - (HasUnitId ipkg, PackageFixedDeps ipkg, - HasUnitId srcpkg, PackageFixedDeps srcpkg) - => Verbosity - -> JobControl IO ( GenericReadyPackage srcpkg - , GenericBuildResult ipkg iresult BuildFailure ) - -> Bool - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - -> ( GenericReadyPackage srcpkg - -> IO (GenericBuildResult ipkg iresult BuildFailure)) - -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure) -executeInstallPlan verbosity jobCtl keepGoing plan0 installPkg = - tryNewTasks False False plan0 - where - tryNewTasks :: Bool -> Bool - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure) - tryNewTasks tasksFailed tasksRemaining plan - | tasksFailed && not keepGoing && not tasksRemaining - = return plan - - | tasksFailed && not keepGoing && tasksRemaining - = waitForTasks tasksFailed plan - - tryNewTasks tasksFailed tasksRemaining plan = do - case InstallPlan.ready plan of - [] | not tasksRemaining -> return plan - | otherwise -> waitForTasks tasksFailed plan - pkgs -> do - sequence_ - [ do debug verbosity $ "Ready to install " ++ display pkgid - spawnJob jobCtl $ do - buildResult <- installPkg pkg - return (pkg, buildResult) - | pkg <- pkgs - , let pkgid = packageId pkg - ] - - let plan' = InstallPlan.processing pkgs plan - waitForTasks tasksFailed plan' - - waitForTasks :: Bool - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - -> IO (GenericInstallPlan ipkg srcpkg iresult BuildFailure) - waitForTasks tasksFailed plan = do - debug verbosity $ "Waiting for install task to finish..." - (pkg, buildResult) <- collectJob jobCtl - let plan' = updatePlan pkg buildResult plan - tasksFailed' = tasksFailed || isBuildFailure buildResult - -- if this is the first failure and we're not trying to keep going - -- then try to cancel as many of the remaining jobs as possible - when (not tasksFailed && isBuildFailure buildResult && not keepGoing) $ - cancelJobs jobCtl - tasksRemaining <- remainingJobs jobCtl - tryNewTasks tasksFailed' tasksRemaining plan' - - isBuildFailure (BuildFailure _) = True - isBuildFailure _ = False - - updatePlan :: GenericReadyPackage srcpkg - -> GenericBuildResult ipkg iresult BuildFailure - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - -> GenericInstallPlan ipkg srcpkg iresult BuildFailure - updatePlan pkg (BuildSuccess ipkgs buildSuccess) = - InstallPlan.completed (installedPackageId pkg) - mipkg - buildSuccess - where - mipkg = case (ipkgs, find (\ipkg -> installedPackageId ipkg - == installedPackageId pkg) ipkgs) of - ([], _) -> Nothing - ((_:_), Just ipkg) -> Just ipkg - ((_:_), Nothing) -> - error $ "executeInstallPlan: package " ++ display (packageId pkg) - ++ " was expected to register the unit " - ++ display (installedPackageId pkg) - ++ " but is actually registering the unit(s) " - ++ intercalate ", " (map (display . installedPackageId) ipkgs) - - updatePlan pkg (BuildFailure buildFailure) = - InstallPlan.failed (installedPackageId pkg) buildFailure depsFailure - where - depsFailure = DependentFailed (packageId pkg) - -- So this first pkgid failed for whatever reason (buildFailure). - -- All the other packages that depended on this pkgid, which we - -- now cannot build, we mark as failing due to 'DependentFailed' - -- which kind of means it was not their fault. -- | Ensure that the package is unpacked in an appropriate directory, either diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 9d67b8fbfbc..924ee0d6442 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/Distribution/Client/ProjectOrchestration.hs @@ -60,8 +60,8 @@ import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectBuilding import Distribution.Client.Types - hiding ( BuildResult, BuildSuccess(..), BuildFailure(..) - , DocsResult(..), TestsResult(..) ) + hiding ( BuildResult, BuildResults, BuildSuccess(..) + , BuildFailure(..), DocsResult(..), TestsResult(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.BuildTarget ( UserBuildTarget, resolveUserBuildTargets @@ -76,7 +76,6 @@ import Distribution.Package hiding (InstalledPackageId, installedPackageId) import qualified Distribution.PackageDescription as PD import Distribution.PackageDescription (FlagAssignment) -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Simple.Setup (HaddockFlags) import Distribution.Simple.Utils (die, notice) @@ -196,14 +195,22 @@ runProjectPreBuildPhase -- runProjectBuildPhase :: Verbosity -> ProjectBuildContext - -> IO ElaboratedInstallPlan + -> IO BuildResults runProjectBuildPhase verbosity ProjectBuildContext {..} = + fmap (Map.union (previousBuildResults pkgsBuildStatus)) $ rebuildTargets verbosity distDirLayout elaboratedPlan elaboratedShared pkgsBuildStatus buildSettings + where + previousBuildResults :: BuildStatusMap -> BuildResults + previousBuildResults = + Map.mapMaybe $ \status -> case status of + BuildStatusUpToDate _ buildSuccess -> Just (Right buildSuccess) + --TODO: [nice to have] record build failures persistently + _ -> Nothing -- Note that it is a deliberate design choice that the 'buildTargets' is -- not passed to phase 1, and the various bits of input config is not @@ -399,7 +406,7 @@ printPlan verbosity ++ " be built (use -v for more details):") : map showPkg pkgs where - pkgs = linearizeInstallPlan elaboratedPlan + pkgs = InstallPlan.executionOrder elaboratedPlan wouldWill | buildSettingDryRun = "would" | otherwise = "will" @@ -460,31 +467,12 @@ printPlan verbosity showMonitorChangedReason MonitorFirstRun = "first run" showMonitorChangedReason MonitorCorruptCache = "cannot read state cache" -linearizeInstallPlan :: ElaboratedInstallPlan -> [ElaboratedReadyPackage] -linearizeInstallPlan = - unfoldr next - where - next plan = case InstallPlan.ready plan of - [] -> Nothing - (pkg:_) -> Just (pkg, plan') - where - ipkgid = installedPackageId pkg - ipkg = Installed.emptyInstalledPackageInfo { - Installed.sourcePackageId = packageId pkg, - Installed.installedUnitId = ipkgid - } - plan' = InstallPlan.completed ipkgid (Just ipkg) - (BuildOk DocsNotTried TestsNotTried) - (InstallPlan.processing [pkg] plan) - --TODO: [code cleanup] This is a bit of a hack, pretending that each package is installed - -- could we use InstallPlan.topologicalOrder? - - -reportBuildFailures :: ElaboratedInstallPlan -> IO () + +reportBuildFailures :: BuildResults -> IO () reportBuildFailures plan = - case [ (pkg, reason) - | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of + case [ (pkgid, reason) + | (pkgid, Left reason) <- Map.toList plan ] of [] -> return () _failed -> exitFailure --TODO: [required eventually] see the old printBuildFailures for an example diff --git a/cabal-install/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/Distribution/Client/ProjectPlanOutput.hs index 3d5853d25b0..2dc10699c23 100644 --- a/cabal-install/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/Distribution/Client/ProjectPlanOutput.hs @@ -85,8 +85,6 @@ encodePlanAsJson elaboratedInstallPlan _elaboratedSharedConfig = [ "depends" J..= map (jdisplay . installedUnitId) v ] | (c,v) <- ComponentDeps.toList (pkgDependencies ecp) ] - toJ _ = error "encodePlanToJson: only expecting PreExisting and Configured" - -- TODO: maybe move this helper to "ComponentDeps" module? -- Or maybe define a 'Text' instance? comp2str c = case c of diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index c5603c0d69c..55530e42f26 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -16,6 +16,7 @@ module Distribution.Client.ProjectPlanning ( -- plan definition. Need to better separate InstallPlan definition. GenericBuildResult(..), BuildResult, + BuildResults, BuildSuccess(..), BuildFailure(..), DocsResult(..), @@ -61,8 +62,8 @@ import Distribution.Client.ProjectConfig import Distribution.Client.ProjectPlanOutput import Distribution.Client.Types - hiding ( BuildResult, BuildSuccess(..), BuildFailure(..) - , DocsResult(..), TestsResult(..) ) + hiding ( BuildResult, BuildResults, BuildSuccess(..) + , BuildFailure(..), DocsResult(..), TestsResult(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.Dependency diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index bc27a00fe86..0d18e565ae5 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs @@ -21,6 +21,7 @@ module Distribution.Client.ProjectPlanning.Types ( -- plan definition. Need to better separate InstallPlan definition. GenericBuildResult(..), BuildResult, + BuildResults, BuildSuccess(..), BuildFailure(..), DocsResult(..), @@ -38,8 +39,8 @@ module Distribution.Client.ProjectPlanning.Types ( import Distribution.Client.PackageHash import Distribution.Client.Types - hiding ( BuildResult, BuildSuccess(..), BuildFailure(..) - , DocsResult(..), TestsResult(..) ) + hiding ( BuildResult, BuildResults, BuildSuccess(..) + , BuildFailure(..), DocsResult(..), TestsResult(..) ) import Distribution.Client.InstallPlan ( GenericInstallPlan, GenericPlanPackage ) import Distribution.Client.SolverInstallPlan @@ -82,12 +83,10 @@ import Control.Exception type ElaboratedInstallPlan = GenericInstallPlan InstalledPackageInfo ElaboratedConfiguredPackage - BuildSuccess BuildFailure type ElaboratedPlanPackage = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage - BuildSuccess BuildFailure --TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle -- even platform and compiler could be different if we're building things @@ -296,6 +295,7 @@ instance (Binary ipkg, Binary iresult, Binary ifailure) => type BuildResult = GenericBuildResult InstalledPackageInfo BuildSuccess BuildFailure +type BuildResults = Map UnitId (Either BuildFailure BuildSuccess) data BuildSuccess = BuildOk DocsResult TestsResult deriving (Eq, Show, Generic) diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index 368acf41eda..c3362e39011 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/cabal-install/Distribution/Client/Types.hs @@ -266,6 +266,8 @@ maybeRepoRemote (RepoSecure r _localDir) = Just r -- ------------------------------------------------------------ type BuildResult = Either BuildFailure BuildSuccess +type BuildResults = Map UnitId (Either BuildFailure BuildSuccess) + data BuildFailure = PlanningFailed | DependentFailed PackageId | DownloadFailed SomeException diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index b86fe57a233..55b01bebf39 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -389,6 +389,7 @@ Test-Suite unit-tests UnitTests.Distribution.Client.UserConfig UnitTests.Distribution.Client.ProjectConfig UnitTests.Distribution.Client.JobControl + UnitTests.Distribution.Client.InstallPlan UnitTests.Distribution.Solver.Modular.PSQ UnitTests.Distribution.Solver.Modular.Solver UnitTests.Distribution.Solver.Modular.DSL diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 9824dc384a4..4eaa0c144db 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -8,9 +8,8 @@ import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.Types (GenericReadyPackage(..), installedPackageId) -import Distribution.Package hiding (installedPackageId) +import Distribution.Package import Distribution.PackageDescription import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Setup (toFlag) @@ -93,9 +92,8 @@ testExceptionInFindingPackage2 config = do testExceptionInConfigureStep :: ProjectConfig -> Assertion testExceptionInConfigureStep config = do - plan <- planProject testdir config - plan' <- executePlan plan - (_pkga1, failure) <- expectPackageFailed plan' pkgidA1 + (plan, res) <- executePlan =<< planProject testdir config + (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 case failure of ConfigureFailed _str -> return () _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure @@ -107,9 +105,8 @@ testExceptionInConfigureStep config = do testExceptionInBuildStep :: ProjectConfig -> Assertion testExceptionInBuildStep config = do - plan <- planProject testdir config - plan' <- executePlan plan - (_pkga1, failure) <- expectPackageFailed plan' pkgidA1 + (plan, res) <- executePlan =<< planProject testdir config + (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 expectBuildFailed failure where testdir = "exception/build" @@ -119,8 +116,8 @@ testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion testSetupScriptStyles config reportSubCase = do reportSubCase (show SetupCustomExplicitDeps) - plan1 <- executePlan =<< planProject testdir1 config - (pkg1, _, _) <- expectPackageInstalled plan1 pkgidA + (plan1, res1) <- executePlan =<< planProject testdir1 config + (pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA pkgSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps hasDefaultSetupDeps pkg1 @?= Just False marker1 <- readFile (basedir testdir1 "marker") @@ -128,8 +125,8 @@ testSetupScriptStyles config reportSubCase = do removeFile (basedir testdir1 "marker") reportSubCase (show SetupCustomImplicitDeps) - plan2 <- executePlan =<< planProject testdir2 config - (pkg2, _, _) <- expectPackageInstalled plan2 pkgidA + (plan2, res2) <- executePlan =<< planProject testdir2 config + (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA pkgSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps hasDefaultSetupDeps pkg2 @?= Just True marker2 <- readFile (basedir testdir2 "marker") @@ -137,8 +134,8 @@ testSetupScriptStyles config reportSubCase = do removeFile (basedir testdir2 "marker") reportSubCase (show SetupNonCustomInternalLib) - plan3 <- executePlan =<< planProject testdir3 config - (pkg3, _, _) <- expectPackageInstalled plan3 pkgidA + (plan3, res3) <- executePlan =<< planProject testdir3 config + (pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA pkgSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib {- --TODO: the SetupNonCustomExternalLib case is hard to test since it @@ -147,8 +144,8 @@ testSetupScriptStyles config reportSubCase = do -- and a corresponding Cabal package that we can use to try and build a -- default Setup.hs. reportSubCase (show SetupNonCustomExternalLib) - plan4 <- executePlan =<< planProject testdir4 config - (pkg4, _, _) <- expectPackageInstalled plan4 pkgidA + (plan4, res4) <- executePlan =<< planProject testdir4 config + (pkg4, _) <- expectPackageInstalled plan4 res4 pkgidA pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib -} where @@ -166,16 +163,17 @@ testBuildKeepGoing :: ProjectConfig -> Assertion testBuildKeepGoing config = do -- P is expected to fail, Q does not depend on P but without -- parallel build and without keep-going then we don't build Q yet. - plan1 <- executePlan =<< planProject testdir (config <> keepGoing False) - (_, failure1) <- expectPackageFailed plan1 pkgidP + (plan1, res1) <- executePlan =<< planProject testdir (config <> keepGoing False) + (_, failure1) <- expectPackageFailed plan1 res1 pkgidP expectBuildFailed failure1 - _ <- expectPackageProcessing plan1 pkgidQ + _ <- expectPackageConfigured plan1 res1 pkgidQ -- With keep-going then we should go on to sucessfully build Q - plan2 <- executePlan =<< planProject testdir (config <> keepGoing True) - (_, failure2) <- expectPackageFailed plan2 pkgidP + (plan2, res2) <- executePlan + =<< planProject testdir (config <> keepGoing True) + (_, failure2) <- expectPackageFailed plan2 res2 pkgidP expectBuildFailed failure2 - _ <- expectPackageInstalled plan2 pkgidQ + _ <- expectPackageInstalled plan2 res2 pkgidQ return () where testdir = "build/keep-going" @@ -193,17 +191,17 @@ testBuildKeepGoing config = do testRegressionIssue3324 :: ProjectConfig -> Assertion testRegressionIssue3324 config = do -- expected failure first time due to missing dep - plan1 <- executePlan =<< planProject testdir config - (_pkgq, failure) <- expectPackageFailed plan1 pkgidQ + (plan1, res1) <- executePlan =<< planProject testdir config + (_pkgq, failure) <- expectPackageFailed plan1 res1 pkgidQ expectBuildFailed failure -- add the missing dep, now it should work let qcabal = basedir testdir "q" "q.cabal" withFileFinallyRestore qcabal $ do appendFile qcabal (" build-depends: p\n") - plan2 <- executePlan =<< planProject testdir config - _ <- expectPackageInstalled plan2 pkgidP - _ <- expectPackageInstalled plan2 pkgidQ + (plan2, res2) <- executePlan =<< planProject testdir config + _ <- expectPackageInstalled plan2 res2 pkgidP + _ <- expectPackageInstalled plan2 res2 pkgidQ return () where testdir = "regression/3324" @@ -238,7 +236,7 @@ planProject testdir cliConfig = do let targets = Map.fromList - [ (installedPackageId pkg, [BuildDefaultComponents]) + [ (installedUnitId pkg, [BuildDefaultComponents]) | InstallPlan.Configured pkg <- InstallPlan.toList elaboratedPlan , pkgBuildStyle pkg == BuildInplaceOnly ] elaboratedPlan' = pruneInstallPlanToTargets targets elaboratedPlan @@ -265,12 +263,13 @@ type PlanDetails = (DistDirLayout, BuildStatusMap, BuildTimeSettings) -executePlan :: PlanDetails -> IO ElaboratedInstallPlan +executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildResults) executePlan (distDirLayout, elaboratedPlan, elaboratedShared, pkgsBuildStatus, buildSettings) = + fmap ((,) elaboratedPlan) $ rebuildTargets verbosity distDirLayout elaboratedPlan @@ -341,66 +340,55 @@ expectException expected action = do Left e -> return e Right _ -> throwIO $ HUnitFailure $ "expected an exception " ++ expected -expectPackagePreExisting :: ElaboratedInstallPlan -> PackageId +expectPackagePreExisting :: ElaboratedInstallPlan -> BuildResults -> PackageId -> IO InstalledPackageInfo -expectPackagePreExisting plan pkgid = do +expectPackagePreExisting plan buildResults pkgid = do planpkg <- expectPlanPackage plan pkgid - case planpkg of - InstallPlan.PreExisting pkg - -> return pkg - _ -> unexpectedPackageState "PreExisting" planpkg + case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of + (InstallPlan.PreExisting pkg, Nothing) + -> return pkg + (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult -expectPackageConfigured :: ElaboratedInstallPlan -> PackageId +expectPackageConfigured :: ElaboratedInstallPlan -> BuildResults -> PackageId -> IO ElaboratedConfiguredPackage -expectPackageConfigured plan pkgid = do +expectPackageConfigured plan buildResults pkgid = do planpkg <- expectPlanPackage plan pkgid - case planpkg of - InstallPlan.Configured pkg - -> return pkg - _ -> unexpectedPackageState "Configured" planpkg - -expectPackageProcessing :: ElaboratedInstallPlan -> PackageId - -> IO ElaboratedConfiguredPackage -expectPackageProcessing plan pkgid = do + case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of + (InstallPlan.Configured pkg, Nothing) + -> return pkg + (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult + +expectPackageInstalled :: ElaboratedInstallPlan -> BuildResults -> PackageId + -> IO (ElaboratedConfiguredPackage, BuildSuccess) +expectPackageInstalled plan buildResults pkgid = do planpkg <- expectPlanPackage plan pkgid - case planpkg of - InstallPlan.Processing (ReadyPackage pkg) - -> return pkg - _ -> unexpectedPackageState "Processing" planpkg - -expectPackageInstalled :: ElaboratedInstallPlan -> PackageId - -> IO (ElaboratedConfiguredPackage, - Maybe InstalledPackageInfo, - BuildSuccess) -expectPackageInstalled plan pkgid = do + case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of + (InstallPlan.Configured pkg, Just (Right result)) + -> return (pkg, result) + (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult + +expectPackageFailed :: ElaboratedInstallPlan -> BuildResults -> PackageId + -> IO (ElaboratedConfiguredPackage, BuildFailure) +expectPackageFailed plan buildResults pkgid = do planpkg <- expectPlanPackage plan pkgid - case planpkg of - InstallPlan.Installed (ReadyPackage pkg) mipkg result - -> return (pkg, mipkg, result) - _ -> unexpectedPackageState "Installed" planpkg - -expectPackageFailed :: ElaboratedInstallPlan -> PackageId - -> IO (ElaboratedConfiguredPackage, - BuildFailure) -expectPackageFailed plan pkgid = do - planpkg <- expectPlanPackage plan pkgid - case planpkg of - InstallPlan.Failed pkg failure - -> return (pkg, failure) - _ -> unexpectedPackageState "Failed" planpkg - -unexpectedPackageState :: String -> ElaboratedPlanPackage -> IO a -unexpectedPackageState expected planpkg = + case (planpkg, InstallPlan.lookupBuildResult planpkg buildResults) of + (InstallPlan.Configured pkg, Just (Left failure)) + -> return (pkg, failure) + (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult + +unexpectedBuildResult :: String -> ElaboratedPlanPackage + -> Maybe (Either BuildFailure BuildSuccess) -> IO a +unexpectedBuildResult expected planpkg buildResult = throwIO $ HUnitFailure $ "expected to find " ++ display (packageId planpkg) ++ " in the " ++ expected ++ " state, but it is actually in the " ++ actual ++ " state." where - actual = case planpkg of - InstallPlan.PreExisting{} -> "PreExisting" - InstallPlan.Configured{} -> "Configured" - InstallPlan.Processing{} -> "Processing" - InstallPlan.Installed{} -> "Installed" - InstallPlan.Failed{} -> "Failed" + actual = case (buildResult, planpkg) of + (Nothing, InstallPlan.PreExisting{}) -> "PreExisting" + (Nothing, InstallPlan.Configured{}) -> "Configured" + (Just (Right _), InstallPlan.Configured{}) -> "Installed" + (Just (Left _), InstallPlan.Configured{}) -> "Failed" + _ -> "Impossible!" expectPlanPackage :: ElaboratedInstallPlan -> PackageId -> IO ElaboratedPlanPackage diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index 522a9ba7a0e..093d7e8f14c 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -22,6 +22,7 @@ import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.ProjectConfig import qualified UnitTests.Distribution.Client.JobControl +import qualified UnitTests.Distribution.Client.InstallPlan import UnitTests.Options @@ -58,6 +59,8 @@ tests mtimeChangeCalibrated = UnitTests.Distribution.Client.ProjectConfig.tests , testGroup "UnitTests.Distribution.Client.JobControl" UnitTests.Distribution.Client.JobControl.tests + , testGroup "UnitTests.Distribution.Client.InstallPlan" + UnitTests.Distribution.Client.InstallPlan.tests ] main :: IO () diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs new file mode 100644 index 00000000000..f4fbf0fbebc --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -0,0 +1,300 @@ +module UnitTests.Distribution.Client.InstallPlan (tests) where + +import Distribution.Package +import Distribution.Version +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (GenericInstallPlan) +import qualified Distribution.Compat.Graph as Graph +import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.PackageFixedDeps +import Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Client.Types +import Distribution.Client.JobControl + +import Data.Graph +import Data.Array hiding (index) +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) +import Data.IORef +import Control.Monad +import Control.Concurrent (threadDelay) +import System.Random +import Test.QuickCheck + +import Test.Tasty +import Test.Tasty.QuickCheck + + +tests :: [TestTree] +tests = + [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder + , testProperty "executionOrder" prop_executionOrder + , testProperty "execute serial" prop_execute_serial + , testProperty "execute parallel" prop_execute_parallel + , testProperty "execute/executionOrder" prop_execute_vs_executionOrder + ] + +prop_reverseTopologicalOrder :: TestInstallPlan -> Bool +prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) = + isReverseTopologicalOrder + graph + (map (toVertex . installedUnitId) + (InstallPlan.reverseTopologicalOrder plan)) + +-- | @executionOrder@ is in reverse topological order +prop_executionOrder :: TestInstallPlan -> Bool +prop_executionOrder (TestInstallPlan plan graph toVertex _) = + isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids + where + pkgids = map installedUnitId (InstallPlan.executionOrder plan) + +-- | @execute@ is in reverse topological order +prop_execute_serial :: TestInstallPlan -> Property +prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) = + ioProperty $ do + jobCtl <- newSerialJobControl + pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) + return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids + +prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property +prop_execute_parallel (Positive (Small maxJobLimit)) + tplan@(TestInstallPlan plan graph toVertex _) = + ioProperty $ do + jobCtl <- newParallelJobControl maxJobLimit + pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do + delay <- randomRIO (0,1000) + threadDelay delay + return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) + && allConfiguredPackages plan == Set.fromList pkgids + +-- | return the packages that are visited by execute, in order. +executeTestInstallPlan :: JobControl IO (UnitId, Either () ()) + -> TestInstallPlan + -> (TestPkg -> IO ()) + -> IO [UnitId] +executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do + resultsRef <- newIORef [] + _ <- InstallPlan.execute jobCtl False (const ()) + plan $ \(ReadyPackage pkg) -> do + visit pkg + atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ()) + return (Right ()) + fmap reverse (readIORef resultsRef) + +-- | @execute@ visits the packages in the same order as @executionOrder@ +prop_execute_vs_executionOrder :: TestInstallPlan -> Property +prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) = + ioProperty $ do + jobCtl <- newSerialJobControl + pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) + let pkgids' = map installedUnitId (InstallPlan.executionOrder plan) + return (pkgids == pkgids') + + +-------------------------- +-- Property helper utils +-- + +-- | A graph topological ordering is a linear ordering of its vertices such +-- that for every directed edge uv from vertex u to vertex v, u comes before v +-- in the ordering. +-- +-- A reverse topological ordering is the swapped: for every directed edge uv +-- from vertex u to vertex v, v comes before u in the ordering. +-- +isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool +isReverseTopologicalOrder g vs = + and [ ixs ! u > ixs ! v + | let ixs = array (bounds g) (zip vs [0::Int ..]) + , (u,v) <- edges g ] + +isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool +isReversePartialTopologicalOrder g vs = + and [ case (ixs ! u, ixs ! v) of + (Just ixu, Just ixv) -> ixu > ixv + _ -> True + | let ixs = array (bounds g) + (zip (range (bounds g)) (repeat Nothing) ++ + zip vs (map Just [0::Int ..])) + , (u,v) <- edges g ] + +allConfiguredPackages :: HasUnitId srcpkg + => GenericInstallPlan ipkg srcpkg -> Set UnitId +allConfiguredPackages plan = + Set.fromList + [ installedUnitId pkg + | InstallPlan.Configured pkg <- InstallPlan.toList plan ] + + +-------------------- +-- Test generators +-- + +data TestInstallPlan = TestInstallPlan + (GenericInstallPlan TestPkg TestPkg) + Graph + (UnitId -> Vertex) + (Vertex -> UnitId) + +instance Show TestInstallPlan where + show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan + +data TestPkg = TestPkg PackageId UnitId [UnitId] + deriving (Eq, Show) + +instance Package TestPkg where + packageId (TestPkg pkgid _ _) = pkgid + +instance HasUnitId TestPkg where + installedUnitId (TestPkg _ ipkgid _) = ipkgid + +instance PackageFixedDeps TestPkg where + depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps + +instance Arbitrary TestInstallPlan where + arbitrary = arbitraryTestInstallPlan + +arbitraryTestInstallPlan :: Gen TestInstallPlan +arbitraryTestInstallPlan = do + graph <- arbitraryAcyclicGraph + (choose (2,5)) + (choose (1,5)) + 0.3 + + plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph + + let toVertexMap = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ] + fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ] + toVertex = (toVertexMap Map.!) + fromVertex = (fromVertexMap Map.!) + + return (TestInstallPlan plan graph toVertex fromVertex) + where + mkTestPkg pkgv depvs = + return (TestPkg pkgid ipkgid deps) + where + pkgid = mkPkgId pkgv + ipkgid = mkUnitIdV pkgv + deps = map mkUnitIdV depvs + mkUnitIdV = mkUnitId . show + mkPkgId v = PackageIdentifier (PackageName ("pkg" ++ show v)) + (Version [1] []) + + +-- | Generate a random 'InstallPlan' following the structure of an existing +-- 'Graph'. +-- +-- It takes generators for installed and source packages and the chance that +-- each package is installed (for those packages with no prerequisites). +-- +arbitraryInstallPlan :: (HasUnitId ipkg, PackageFixedDeps ipkg, + HasUnitId srcpkg, PackageFixedDeps srcpkg) + => (Vertex -> [Vertex] -> Gen ipkg) + -> (Vertex -> [Vertex] -> Gen srcpkg) + -> Float + -> Graph + -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg) +arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do + + (ipkgvs, srcpkgvs) <- + fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs)) + . partition snd) $ + sequence + [ do isipkg <- if isRoot then pick ipkgProportion + else return False + return (v, isipkg) + | (v,n) <- assocs (outdegree graph) + , let isRoot = n == 0 ] + + ipkgs <- sequence + [ mkIPkg pkgv depvs + | pkgv <- ipkgvs + , let depvs = graph ! pkgv + ] + srcpkgs <- sequence + [ mkSrcPkg pkgv depvs + | pkgv <- srcpkgvs + , let depvs = graph ! pkgv + ] + let index = Graph.fromList (map InstallPlan.PreExisting ipkgs + ++ map InstallPlan.Configured srcpkgs) + case InstallPlan.new (IndependentGoals False) index of + Right plan -> return plan + Left _ -> error "arbitraryInstallPlan: generated invalid plan" + + +-- | Generate a random directed acyclic graph, based on the algorithm presented +-- here +-- +-- It generates a DAG based on ranks of nodes. Nodes in each rank can only +-- have edges to nodes in subsequent ranks. +-- +-- The generator is paramterised by a generator for the number of ranks and +-- the number of nodes within each rank. It is also paramterised by the +-- chance that each node in each rank will have an edge from each node in +-- each previous rank. Thus a higher chance will produce a more densely +-- connected graph. +-- +arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph +arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do + nranks <- genNRanks + rankSizes <- replicateM nranks genNPerRank + let rankStarts = scanl (+) 0 rankSizes + rankRanges = drop 1 (zip rankStarts (tail rankStarts)) + totalRange = sum rankSizes + rankEdges <- mapM (uncurry genRank) rankRanges + return $ buildG (0, totalRange-1) (concat rankEdges) + where + genRank :: Vertex -> Vertex -> Gen [Edge] + genRank rankStart rankEnd = + filterM (const (pick edgeChance)) + [ (i,j) + | i <- [0..rankStart-1] + , j <- [rankStart..rankEnd-1] + ] + +pick :: Float -> Gen Bool +pick chance = do + p <- choose (0,1) + return (p < chance) + + +-------------------------------- +-- Inspecting generated graphs +-- + +{- +-- Handy util for checking the generated graphs look sensible +writeDotFile :: FilePath -> Graph -> IO () +writeDotFile file = writeFile file . renderDotGraph + +renderDotGraph :: Graph -> String +renderDotGraph graph = + unlines ( + [header + ,graphDefaultAtribs + ,nodeDefaultAtribs + ,edgeDefaultAtribs] + ++ map renderNode (vertices graph) + ++ map renderEdge (edges graph) + ++ [footer] + ) + where + renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++ "\"];" + + renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" + + +header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String + +header = "digraph packages {" +footer = "}" + +graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];" +nodeDefaultAtribs = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];" +edgeDefaultAtribs = "\tedge [fontsize=10];" +-}