{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.InstallPlan
-- Copyright   :  (c) Duncan Coutts 2008
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Package installation plan
module Distribution.Client.InstallPlan
  ( InstallPlan
  , GenericInstallPlan
  , PlanPackage
  , GenericPlanPackage (..)
  , foldPlanPackage
  , IsUnit

    -- * Operations on 'InstallPlan's
  , new
  , toGraph
  , toList
  , toMap
  , keys
  , keysSet
  , planIndepGoals
  , depends
  , fromSolverInstallPlan
  , fromSolverInstallPlanWithProgress
  , configureInstallPlan
  , remove
  , installed
  , lookup
  , directDeps
  , revDirectDeps

    -- * Traversal
  , executionOrder
  , execute
  , BuildOutcomes
  , lookupBuildOutcome

    -- ** Traversal helpers
    -- $traversal
  , Processing
  , ready
  , completed
  , failed

    -- * Display
  , showPlanGraph
  , ShowPlanNode (..)
  , showInstallPlan
  , showInstallPlan_gen
  , showPlanPackageTag

    -- * Graph-like operations
  , dependencyClosure
  , reverseTopologicalOrder
  , reverseDependencyClosure
  ) where

import Distribution.Client.Compat.Prelude hiding (lookup, toList)
import Distribution.Compat.Stack (WithCallStack)
import Prelude ()

import Distribution.Client.Types hiding (BuildOutcomes)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Simple.Configure as Configure
import qualified Distribution.Simple.Setup as Cabal

import Distribution.Client.JobControl
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.InstalledPackageInfo
  ( InstalledPackageInfo
  )
import Distribution.Package
  ( HasMungedPackageId (..)
  , HasUnitId (..)
  , Package (..)
  , UnitId
  )
import Distribution.Pretty (defaultStyle)
import Distribution.Solver.Types.SolverPackage
import Text.PrettyPrint

import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.InstSolverPackage
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.SolverId

import Distribution.Utils.LogProgress
import Distribution.Utils.Structured (Structure (Nominal), Structured (..))

-- TODO: Need this when we compute final UnitIds
-- import qualified Distribution.Simple.Configure as Configure

import Control.Exception
  ( assert
  )
import qualified Data.Foldable as Foldable (all, toList)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Compat.Graph (Graph, IsNode (..))
import qualified Distribution.Compat.Graph as Graph

-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
--
-- The Problem:
--
-- In general we start with a set of installed packages and a set of source
-- packages.
--
-- Installed packages have fixed dependencies. They have already been built and
-- we know exactly what packages they were built against, including their exact
-- versions.
--
-- Source package have somewhat flexible dependencies. They are specified as
-- version ranges, though really they're predicates. To make matters worse they
-- have conditional flexible dependencies. Configuration flags can affect which
-- packages are required and can place additional constraints on their
-- versions.
--
-- These two sets of package can and usually do overlap. There can be installed
-- packages that are also available as source packages which means they could
-- be re-installed if required, though there will also be packages which are
-- not available as source and cannot be re-installed. Very often there will be
-- extra versions available than are installed. Sometimes we may like to prefer
-- installed packages over source ones or perhaps always prefer the latest
-- available version whether installed or not.
--
-- The goal is to calculate an installation plan that is closed, acyclic and
-- consistent and where every configured package is valid.
--
-- An installation plan is a set of packages that are going to be used
-- together. It will consist of a mixture of installed packages and source
-- packages along with their exact version dependencies. An installation plan
-- is closed if for every package in the set, all of its dependencies are
-- also in the set. It is consistent if for every package in the set, all
-- dependencies which target that package have the same version.

-- Note that plans do not necessarily compose. You might have a valid plan for
-- package A and a valid plan for package B. That does not mean the composition
-- is simultaneously valid for A and B. In particular you're most likely to
-- have problems with inconsistent dependencies.
-- On the other hand it is true that every closed sub plan is valid.

-- | Packages in an install plan
--
-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
-- intentionally have no 'PackageInstalled' instance. `This is important:
-- PackageInstalled returns only library dependencies, but for package that
-- aren't yet installed we know many more kinds of dependencies (setup
-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
-- dependencies in cabal-install should consider what to do with these
-- 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 'PackageInstalled'.
data GenericPlanPackage ipkg srcpkg
  = PreExisting ipkg
  | Configured srcpkg
  | Installed srcpkg
  deriving (GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
(GenericPlanPackage ipkg srcpkg
 -> GenericPlanPackage ipkg srcpkg -> Bool)
-> (GenericPlanPackage ipkg srcpkg
    -> GenericPlanPackage ipkg srcpkg -> Bool)
-> Eq (GenericPlanPackage ipkg srcpkg)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall ipkg srcpkg.
(Eq ipkg, Eq srcpkg) =>
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
$c== :: forall ipkg srcpkg.
(Eq ipkg, Eq srcpkg) =>
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
== :: GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
$c/= :: forall ipkg srcpkg.
(Eq ipkg, Eq srcpkg) =>
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
/= :: GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
Eq, Int -> GenericPlanPackage ipkg srcpkg -> ShowS
[GenericPlanPackage ipkg srcpkg] -> ShowS
GenericPlanPackage ipkg srcpkg -> String
(Int -> GenericPlanPackage ipkg srcpkg -> ShowS)
-> (GenericPlanPackage ipkg srcpkg -> String)
-> ([GenericPlanPackage ipkg srcpkg] -> ShowS)
-> Show (GenericPlanPackage ipkg srcpkg)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
Int -> GenericPlanPackage ipkg srcpkg -> ShowS
forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
[GenericPlanPackage ipkg srcpkg] -> ShowS
forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
GenericPlanPackage ipkg srcpkg -> String
$cshowsPrec :: forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
Int -> GenericPlanPackage ipkg srcpkg -> ShowS
showsPrec :: Int -> GenericPlanPackage ipkg srcpkg -> ShowS
$cshow :: forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
GenericPlanPackage ipkg srcpkg -> String
show :: GenericPlanPackage ipkg srcpkg -> String
$cshowList :: forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
[GenericPlanPackage ipkg srcpkg] -> ShowS
showList :: [GenericPlanPackage ipkg srcpkg] -> ShowS
Show, (forall x.
 GenericPlanPackage ipkg srcpkg
 -> Rep (GenericPlanPackage ipkg srcpkg) x)
-> (forall x.
    Rep (GenericPlanPackage ipkg srcpkg) x
    -> GenericPlanPackage ipkg srcpkg)
-> Generic (GenericPlanPackage ipkg srcpkg)
forall x.
Rep (GenericPlanPackage ipkg srcpkg) x
-> GenericPlanPackage ipkg srcpkg
forall x.
GenericPlanPackage ipkg srcpkg
-> Rep (GenericPlanPackage ipkg srcpkg) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall ipkg srcpkg x.
Rep (GenericPlanPackage ipkg srcpkg) x
-> GenericPlanPackage ipkg srcpkg
forall ipkg srcpkg x.
GenericPlanPackage ipkg srcpkg
-> Rep (GenericPlanPackage ipkg srcpkg) x
$cfrom :: forall ipkg srcpkg x.
GenericPlanPackage ipkg srcpkg
-> Rep (GenericPlanPackage ipkg srcpkg) x
from :: forall x.
GenericPlanPackage ipkg srcpkg
-> Rep (GenericPlanPackage ipkg srcpkg) x
$cto :: forall ipkg srcpkg x.
Rep (GenericPlanPackage ipkg srcpkg) x
-> GenericPlanPackage ipkg srcpkg
to :: forall x.
Rep (GenericPlanPackage ipkg srcpkg) x
-> GenericPlanPackage ipkg srcpkg
Generic)

displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String
displayGenericPlanPackage :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericPlanPackage ipkg srcpkg -> String
displayGenericPlanPackage (PreExisting ipkg
pkg) = String
"PreExisting " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (ipkg -> Key ipkg
forall a. IsNode a => a -> Key a
nodeKey ipkg
pkg)
displayGenericPlanPackage (Configured srcpkg
pkg) = String
"Configured " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
pkg)
displayGenericPlanPackage (Installed srcpkg
pkg) = String
"Installed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
pkg)

-- | Convenience combinator for destructing 'GenericPlanPackage'.
-- This is handy because if you case manually, you have to handle
-- 'Configured' and 'Installed' separately (where often you want
-- them to be the same.)
foldPlanPackage
  :: (ipkg -> a)
  -> (srcpkg -> a)
  -> GenericPlanPackage ipkg srcpkg
  -> a
foldPlanPackage :: forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
foldPlanPackage ipkg -> a
f srcpkg -> a
_ (PreExisting ipkg
ipkg) = ipkg -> a
f ipkg
ipkg
foldPlanPackage ipkg -> a
_ srcpkg -> a
g (Configured srcpkg
srcpkg) = srcpkg -> a
g srcpkg
srcpkg
foldPlanPackage ipkg -> a
_ srcpkg -> a
g (Installed srcpkg
srcpkg) = srcpkg -> a
g srcpkg
srcpkg

type IsUnit a = (IsNode a, Key a ~ UnitId)

depends :: IsUnit a => a -> [UnitId]
depends :: forall a. IsUnit a => a -> [UnitId]
depends = a -> [UnitId]
a -> [Key a]
forall a. IsNode a => a -> [Key a]
nodeNeighbors

-- NB: Expanded constraint synonym here to avoid undecidable
-- instance errors in GHC 7.8 and earlier.
instance
  (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
  => IsNode (GenericPlanPackage ipkg srcpkg)
  where
  type Key (GenericPlanPackage ipkg srcpkg) = UnitId
  nodeKey :: GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
nodeKey (PreExisting ipkg
ipkg) = ipkg -> Key ipkg
forall a. IsNode a => a -> Key a
nodeKey ipkg
ipkg
  nodeKey (Configured srcpkg
spkg) = srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
spkg
  nodeKey (Installed srcpkg
spkg) = srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
spkg
  nodeNeighbors :: GenericPlanPackage ipkg srcpkg
-> [Key (GenericPlanPackage ipkg srcpkg)]
nodeNeighbors (PreExisting ipkg
ipkg) = ipkg -> [Key ipkg]
forall a. IsNode a => a -> [Key a]
nodeNeighbors ipkg
ipkg
  nodeNeighbors (Configured srcpkg
spkg) = srcpkg -> [Key srcpkg]
forall a. IsNode a => a -> [Key a]
nodeNeighbors srcpkg
spkg
  nodeNeighbors (Installed srcpkg
spkg) = srcpkg -> [Key srcpkg]
forall a. IsNode a => a -> [Key a]
nodeNeighbors srcpkg
spkg

instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)
instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg)

type PlanPackage =
  GenericPlanPackage
    InstalledPackageInfo
    (ConfiguredPackage UnresolvedPkgLoc)

instance
  (Package ipkg, Package srcpkg)
  => Package (GenericPlanPackage ipkg srcpkg)
  where
  packageId :: GenericPlanPackage ipkg srcpkg -> PackageIdentifier
packageId (PreExisting ipkg
ipkg) = ipkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ipkg
ipkg
  packageId (Configured srcpkg
spkg) = srcpkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId srcpkg
spkg
  packageId (Installed srcpkg
spkg) = srcpkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId srcpkg
spkg

instance
  (HasMungedPackageId ipkg, HasMungedPackageId srcpkg)
  => HasMungedPackageId (GenericPlanPackage ipkg srcpkg)
  where
  mungedId :: GenericPlanPackage ipkg srcpkg -> MungedPackageId
mungedId (PreExisting ipkg
ipkg) = ipkg -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId ipkg
ipkg
  mungedId (Configured srcpkg
spkg) = srcpkg -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId srcpkg
spkg
  mungedId (Installed srcpkg
spkg) = srcpkg -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId srcpkg
spkg

instance
  (HasUnitId ipkg, HasUnitId srcpkg)
  => HasUnitId
      (GenericPlanPackage ipkg srcpkg)
  where
  installedUnitId :: GenericPlanPackage ipkg srcpkg -> UnitId
installedUnitId (PreExisting ipkg
ipkg) = ipkg -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ipkg
ipkg
  installedUnitId (Configured srcpkg
spkg) = srcpkg -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId srcpkg
spkg
  installedUnitId (Installed srcpkg
spkg) = srcpkg -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId srcpkg
spkg

instance
  (HasConfiguredId ipkg, HasConfiguredId srcpkg)
  => HasConfiguredId (GenericPlanPackage ipkg srcpkg)
  where
  configuredId :: GenericPlanPackage ipkg srcpkg -> ConfiguredId
configuredId (PreExisting ipkg
ipkg) = ipkg -> ConfiguredId
forall a. HasConfiguredId a => a -> ConfiguredId
configuredId ipkg
ipkg
  configuredId (Configured srcpkg
spkg) = srcpkg -> ConfiguredId
forall a. HasConfiguredId a => a -> ConfiguredId
configuredId srcpkg
spkg
  configuredId (Installed srcpkg
spkg) = srcpkg -> ConfiguredId
forall a. HasConfiguredId a => a -> ConfiguredId
configuredId srcpkg
spkg

data GenericInstallPlan ipkg srcpkg = GenericInstallPlan
  { forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg))
  , forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> IndependentGoals
planIndepGoals :: !IndependentGoals
  }
  deriving (Typeable)

-- | 'GenericInstallPlan' specialised to most commonly used types.
type InstallPlan =
  GenericInstallPlan
    InstalledPackageInfo
    (ConfiguredPackage UnresolvedPkgLoc)

-- | Smart constructor that deals with caching the 'Graph' representation.
mkInstallPlan
  :: (IsUnit ipkg, IsUnit srcpkg)
  => String
  -> Graph (GenericPlanPackage ipkg srcpkg)
  -> IndependentGoals
  -> GenericInstallPlan ipkg srcpkg
mkInstallPlan :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
loc Graph (GenericPlanPackage ipkg srcpkg)
graph IndependentGoals
indepGoals =
  Bool
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
forall a. (?callStack::CallStack) => Bool -> a -> a
assert
    (String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
valid String
loc Graph (GenericPlanPackage ipkg srcpkg)
graph)
    GenericInstallPlan
      { planGraph :: Graph (GenericPlanPackage ipkg srcpkg)
planGraph = Graph (GenericPlanPackage ipkg srcpkg)
graph
      , planIndepGoals :: IndependentGoals
planIndepGoals = IndependentGoals
indepGoals
      }

internalError :: WithCallStack (String -> String -> a)
internalError :: forall a. WithCallStack (String -> String -> a)
internalError String
loc String
msg =
  String -> a
forall a. (?callStack::CallStack) => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$
    String
"internal error in InstallPlan."
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
loc
      String -> ShowS
forall a. [a] -> [a] -> [a]
++ if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then String
"" else String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where
  structure :: Proxy (GenericInstallPlan ipkg srcpkg) -> Structure
structure Proxy (GenericInstallPlan ipkg srcpkg)
p =
    TypeRep -> TypeVersion -> String -> [Structure] -> Structure
Nominal
      (Proxy (GenericInstallPlan ipkg srcpkg) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (GenericInstallPlan ipkg srcpkg)
p)
      TypeVersion
0
      String
"GenericInstallPlan"
      [ Proxy ipkg -> Structure
forall a. Structured a => Proxy a -> Structure
structure (Proxy ipkg
forall {k} (t :: k). Proxy t
Proxy :: Proxy ipkg)
      , Proxy srcpkg -> Structure
forall a. Structured a => Proxy a -> Structure
structure (Proxy srcpkg
forall {k} (t :: k). Proxy t
Proxy :: Proxy srcpkg)
      ]

instance
  ( IsNode ipkg
  , Key ipkg ~ UnitId
  , IsNode srcpkg
  , Key srcpkg ~ UnitId
  , Binary ipkg
  , Binary srcpkg
  )
  => Binary (GenericInstallPlan ipkg srcpkg)
  where
  put :: GenericInstallPlan ipkg srcpkg -> Put
put
    GenericInstallPlan
      { planGraph :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph = Graph (GenericPlanPackage ipkg srcpkg)
graph
      , planIndepGoals :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> IndependentGoals
planIndepGoals = IndependentGoals
indepGoals
      } = Graph (GenericPlanPackage ipkg srcpkg) -> Put
forall t. Binary t => t -> Put
put Graph (GenericPlanPackage ipkg srcpkg)
graph Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IndependentGoals -> Put
forall t. Binary t => t -> Put
put IndependentGoals
indepGoals

  get :: Get (GenericInstallPlan ipkg srcpkg)
get = do
    Graph (GenericPlanPackage ipkg srcpkg)
graph <- Get (Graph (GenericPlanPackage ipkg srcpkg))
forall t. Binary t => Get t
get
    IndependentGoals
indepGoals <- Get IndependentGoals
forall t. Binary t => Get t
get
    GenericInstallPlan ipkg srcpkg
-> Get (GenericInstallPlan ipkg srcpkg)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericInstallPlan ipkg srcpkg
 -> Get (GenericInstallPlan ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> Get (GenericInstallPlan ipkg srcpkg)
forall a b. (a -> b) -> a -> b
$! String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
"(instance Binary)" Graph (GenericPlanPackage ipkg srcpkg)
graph IndependentGoals
indepGoals

data ShowPlanNode = ShowPlanNode
  { ShowPlanNode -> Doc
showPlanHerald :: Doc
  , ShowPlanNode -> [Doc]
showPlanNeighbours :: [Doc]
  }

showPlanGraph :: [ShowPlanNode] -> String
showPlanGraph :: [ShowPlanNode] -> String
showPlanGraph [ShowPlanNode]
graph =
  Style -> Doc -> String
renderStyle Style
defaultStyle (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
vcat ((ShowPlanNode -> Doc) -> [ShowPlanNode] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ShowPlanNode -> Doc
dispPlanPackage [ShowPlanNode]
graph)
  where
    dispPlanPackage :: ShowPlanNode -> Doc
dispPlanPackage (ShowPlanNode Doc
herald [Doc]
neighbours) =
      Doc -> Int -> Doc -> Doc
hang Doc
herald Int
2 ([Doc] -> Doc
vcat [Doc]
neighbours)

-- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information
showInstallPlan_gen
  :: forall ipkg srcpkg
   . (GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
  -> GenericInstallPlan ipkg srcpkg
  -> String
showInstallPlan_gen :: forall ipkg srcpkg.
(GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
-> GenericInstallPlan ipkg srcpkg -> String
showInstallPlan_gen GenericPlanPackage ipkg srcpkg -> ShowPlanNode
toShow = [ShowPlanNode] -> String
showPlanGraph ([ShowPlanNode] -> String)
-> (GenericInstallPlan ipkg srcpkg -> [ShowPlanNode])
-> GenericInstallPlan ipkg srcpkg
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
-> [GenericPlanPackage ipkg srcpkg] -> [ShowPlanNode]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericPlanPackage ipkg srcpkg -> ShowPlanNode
toShow ([GenericPlanPackage ipkg srcpkg] -> [ShowPlanNode])
-> (GenericInstallPlan ipkg srcpkg
    -> [GenericPlanPackage ipkg srcpkg])
-> GenericInstallPlan ipkg srcpkg
-> [ShowPlanNode]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph (GenericPlanPackage ipkg srcpkg)
-> [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Graph (GenericPlanPackage ipkg srcpkg)
 -> [GenericPlanPackage ipkg srcpkg])
-> (GenericInstallPlan ipkg srcpkg
    -> Graph (GenericPlanPackage ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

showInstallPlan
  :: forall ipkg srcpkg
   . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> String
showInstallPlan :: forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> String
showInstallPlan = (GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
-> GenericInstallPlan ipkg srcpkg -> String
forall ipkg srcpkg.
(GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
-> GenericInstallPlan ipkg srcpkg -> String
showInstallPlan_gen GenericPlanPackage ipkg srcpkg -> ShowPlanNode
toShow
  where
    toShow :: GenericPlanPackage ipkg srcpkg -> ShowPlanNode
    toShow :: GenericPlanPackage ipkg srcpkg -> ShowPlanNode
toShow GenericPlanPackage ipkg srcpkg
p =
      Doc -> [Doc] -> ShowPlanNode
ShowPlanNode
        ( [Doc] -> Doc
hsep
            [ String -> Doc
text (GenericPlanPackage ipkg srcpkg -> String
forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag GenericPlanPackage ipkg srcpkg
p)
            , PackageIdentifier -> Doc
forall a. Pretty a => a -> Doc
pretty (GenericPlanPackage ipkg srcpkg -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPlanPackage ipkg srcpkg
p)
            , Doc -> Doc
parens (UnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
p))
            ]
        )
        ((UnitId -> Doc) -> [UnitId] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> Doc
forall a. Pretty a => a -> Doc
pretty (GenericPlanPackage ipkg srcpkg
-> [Key (GenericPlanPackage ipkg srcpkg)]
forall a. IsNode a => a -> [Key a]
nodeNeighbors GenericPlanPackage ipkg srcpkg
p))

showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag :: forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag (PreExisting ipkg
_) = String
"PreExisting"
showPlanPackageTag (Configured srcpkg
_) = String
"Configured"
showPlanPackageTag (Installed srcpkg
_) = String
"Installed"

-- | Build an installation plan from a valid set of resolved packages.
new
  :: (IsUnit ipkg, IsUnit srcpkg)
  => IndependentGoals
  -> Graph (GenericPlanPackage ipkg srcpkg)
  -> GenericInstallPlan ipkg srcpkg
new :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
IndependentGoals
-> Graph (GenericPlanPackage ipkg srcpkg)
-> GenericInstallPlan ipkg srcpkg
new IndependentGoals
indepGoals Graph (GenericPlanPackage ipkg srcpkg)
graph = String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
"new" Graph (GenericPlanPackage ipkg srcpkg)
graph IndependentGoals
indepGoals

toGraph
  :: GenericInstallPlan ipkg srcpkg
  -> Graph (GenericPlanPackage ipkg srcpkg)
toGraph :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
toGraph = GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

toList
  :: GenericInstallPlan ipkg srcpkg
  -> [GenericPlanPackage ipkg srcpkg]
toList :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
toList = Graph (GenericPlanPackage ipkg srcpkg)
-> [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList (Graph (GenericPlanPackage ipkg srcpkg)
 -> [GenericPlanPackage ipkg srcpkg])
-> (GenericInstallPlan ipkg srcpkg
    -> Graph (GenericPlanPackage ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> [GenericPlanPackage ipkg srcpkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

toMap
  :: GenericInstallPlan ipkg srcpkg
  -> Map UnitId (GenericPlanPackage ipkg srcpkg)
toMap :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
toMap = Graph (GenericPlanPackage ipkg srcpkg)
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
Graph (GenericPlanPackage ipkg srcpkg)
-> Map
     (Key (GenericPlanPackage ipkg srcpkg))
     (GenericPlanPackage ipkg srcpkg)
forall a. Graph a -> Map (Key a) a
Graph.toMap (Graph (GenericPlanPackage ipkg srcpkg)
 -> Map UnitId (GenericPlanPackage ipkg srcpkg))
-> (GenericInstallPlan ipkg srcpkg
    -> Graph (GenericPlanPackage ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
keys :: forall ipkg srcpkg. GenericInstallPlan ipkg srcpkg -> [UnitId]
keys = Graph (GenericPlanPackage ipkg srcpkg) -> [UnitId]
Graph (GenericPlanPackage ipkg srcpkg)
-> [Key (GenericPlanPackage ipkg srcpkg)]
forall a. Graph a -> [Key a]
Graph.keys (Graph (GenericPlanPackage ipkg srcpkg) -> [UnitId])
-> (GenericInstallPlan ipkg srcpkg
    -> Graph (GenericPlanPackage ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
keysSet :: forall ipkg srcpkg. GenericInstallPlan ipkg srcpkg -> Set UnitId
keysSet = Graph (GenericPlanPackage ipkg srcpkg) -> Set UnitId
Graph (GenericPlanPackage ipkg srcpkg)
-> Set (Key (GenericPlanPackage ipkg srcpkg))
forall a. Graph a -> Set (Key a)
Graph.keysSet (Graph (GenericPlanPackage ipkg srcpkg) -> Set UnitId)
-> (GenericInstallPlan ipkg srcpkg
    -> Graph (GenericPlanPackage ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

-- | Remove packages from the install plan. This will result in an
-- error if there are remaining packages that depend on any matching
-- package. This is primarily useful for obtaining an install plan for
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
remove
  :: (IsUnit ipkg, IsUnit srcpkg)
  => (GenericPlanPackage ipkg srcpkg -> Bool)
  -> GenericInstallPlan ipkg srcpkg
  -> GenericInstallPlan ipkg srcpkg
remove :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
(GenericPlanPackage ipkg srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
remove GenericPlanPackage ipkg srcpkg -> Bool
shouldRemove GenericInstallPlan ipkg srcpkg
plan =
  String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
"remove" Graph (GenericPlanPackage ipkg srcpkg)
newGraph (GenericInstallPlan ipkg srcpkg -> IndependentGoals
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> IndependentGoals
planIndepGoals GenericInstallPlan ipkg srcpkg
plan)
  where
    newGraph :: Graph (GenericPlanPackage ipkg srcpkg)
newGraph =
      [GenericPlanPackage ipkg srcpkg]
-> Graph (GenericPlanPackage ipkg srcpkg)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList ([GenericPlanPackage ipkg srcpkg]
 -> Graph (GenericPlanPackage ipkg srcpkg))
-> [GenericPlanPackage ipkg srcpkg]
-> Graph (GenericPlanPackage ipkg srcpkg)
forall a b. (a -> b) -> a -> b
$
        (GenericPlanPackage ipkg srcpkg -> Bool)
-> [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (GenericPlanPackage ipkg srcpkg -> Bool)
-> GenericPlanPackage ipkg srcpkg
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPlanPackage ipkg srcpkg -> Bool
shouldRemove) (GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
toList GenericInstallPlan ipkg srcpkg
plan)

-- | Change a number of packages in the 'Configured' state to the 'Installed'
-- state.
--
-- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed').
installed
  :: (IsUnit ipkg, IsUnit srcpkg)
  => (srcpkg -> Bool)
  -> GenericInstallPlan ipkg srcpkg
  -> GenericInstallPlan ipkg srcpkg
installed :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
(srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
installed srcpkg -> Bool
shouldBeInstalled GenericInstallPlan ipkg srcpkg
installPlan =
  (GenericInstallPlan ipkg srcpkg
 -> srcpkg -> GenericInstallPlan ipkg srcpkg)
-> GenericInstallPlan ipkg srcpkg
-> [srcpkg]
-> GenericInstallPlan ipkg srcpkg
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    GenericInstallPlan ipkg srcpkg
-> srcpkg -> GenericInstallPlan ipkg srcpkg
forall {ipkg} {srcpkg}.
(Key ipkg ~ UnitId, Key srcpkg ~ UnitId, IsNode srcpkg,
 IsNode ipkg) =>
GenericInstallPlan ipkg srcpkg
-> srcpkg -> GenericInstallPlan ipkg srcpkg
markInstalled
    GenericInstallPlan ipkg srcpkg
installPlan
    [ srcpkg
pkg
    | Configured srcpkg
pkg <- GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
reverseTopologicalOrder GenericInstallPlan ipkg srcpkg
installPlan
    , srcpkg -> Bool
shouldBeInstalled srcpkg
pkg
    ]
  where
    markInstalled :: GenericInstallPlan ipkg srcpkg
-> srcpkg -> GenericInstallPlan ipkg srcpkg
markInstalled GenericInstallPlan ipkg srcpkg
plan srcpkg
pkg =
      Bool
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((GenericPlanPackage ipkg srcpkg -> Bool)
-> [GenericPlanPackage ipkg srcpkg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenericPlanPackage ipkg srcpkg -> Bool
forall a b. GenericPlanPackage a b -> Bool
isInstalled (GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan (srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
pkg))) (GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg)
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
forall a b. (a -> b) -> a -> b
$
        GenericInstallPlan ipkg srcpkg
plan
          { planGraph = Graph.insert (Installed pkg) (planGraph plan)
          }

-- | Lookup a package in the plan.
lookup
  :: (IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> UnitId
  -> Maybe (GenericPlanPackage ipkg srcpkg)
lookup :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> UnitId -> Maybe (GenericPlanPackage ipkg srcpkg)
lookup GenericInstallPlan ipkg srcpkg
plan UnitId
pkgid = Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup UnitId
Key (GenericPlanPackage ipkg srcpkg)
pkgid (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)

-- | Find all the direct dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
directDeps
  :: GenericInstallPlan ipkg srcpkg
  -> UnitId
  -> [GenericPlanPackage ipkg srcpkg]
directDeps :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan UnitId
pkgid =
  case Graph (GenericPlanPackage ipkg srcpkg)
-> Key (GenericPlanPackage ipkg srcpkg)
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> Key a -> Maybe [a]
Graph.neighbors (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) UnitId
Key (GenericPlanPackage ipkg srcpkg)
pkgid of
    Just [GenericPlanPackage ipkg srcpkg]
deps -> [GenericPlanPackage ipkg srcpkg]
deps
    Maybe [GenericPlanPackage ipkg srcpkg]
Nothing -> String -> String -> [GenericPlanPackage ipkg srcpkg]
forall a. WithCallStack (String -> String -> a)
internalError String
"directDeps" String
"package not in graph"

-- | Find all the direct reverse dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
revDirectDeps
  :: GenericInstallPlan ipkg srcpkg
  -> UnitId
  -> [GenericPlanPackage ipkg srcpkg]
revDirectDeps :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
revDirectDeps GenericInstallPlan ipkg srcpkg
plan UnitId
pkgid =
  case Graph (GenericPlanPackage ipkg srcpkg)
-> Key (GenericPlanPackage ipkg srcpkg)
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> Key a -> Maybe [a]
Graph.revNeighbors (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) UnitId
Key (GenericPlanPackage ipkg srcpkg)
pkgid of
    Just [GenericPlanPackage ipkg srcpkg]
deps -> [GenericPlanPackage ipkg srcpkg]
deps
    Maybe [GenericPlanPackage ipkg srcpkg]
Nothing -> String -> String -> [GenericPlanPackage ipkg srcpkg]
forall a. WithCallStack (String -> String -> a)
internalError String
"revDirectDeps" String
"package not in graph"

-- | Return all the packages in the 'InstallPlan' in reverse topological order.
-- That is, for each package, all dependencies 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 :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
reverseTopologicalOrder GenericInstallPlan ipkg srcpkg
plan = Graph (GenericPlanPackage ipkg srcpkg)
-> [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [a]
Graph.revTopSort (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)

-- | Return the packages in the plan that are direct or indirect dependencies of
-- the given packages.
dependencyClosure
  :: GenericInstallPlan ipkg srcpkg
  -> [UnitId]
  -> [GenericPlanPackage ipkg srcpkg]
dependencyClosure :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
dependencyClosure GenericInstallPlan ipkg srcpkg
plan =
  [GenericPlanPackage ipkg srcpkg]
-> Maybe [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. a -> Maybe a -> a
fromMaybe []
    (Maybe [GenericPlanPackage ipkg srcpkg]
 -> [GenericPlanPackage ipkg srcpkg])
-> ([UnitId] -> Maybe [GenericPlanPackage ipkg srcpkg])
-> [UnitId]
-> [GenericPlanPackage ipkg srcpkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph (GenericPlanPackage ipkg srcpkg)
-> [Key (GenericPlanPackage ipkg srcpkg)]
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.closure (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)

-- | Return the packages in the plan that depend directly or indirectly on the
-- given packages.
reverseDependencyClosure
  :: GenericInstallPlan ipkg srcpkg
  -> [UnitId]
  -> [GenericPlanPackage ipkg srcpkg]
reverseDependencyClosure :: forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
reverseDependencyClosure GenericInstallPlan ipkg srcpkg
plan =
  [GenericPlanPackage ipkg srcpkg]
-> Maybe [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. a -> Maybe a -> a
fromMaybe []
    (Maybe [GenericPlanPackage ipkg srcpkg]
 -> [GenericPlanPackage ipkg srcpkg])
-> ([UnitId] -> Maybe [GenericPlanPackage ipkg srcpkg])
-> [UnitId]
-> [GenericPlanPackage ipkg srcpkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph (GenericPlanPackage ipkg srcpkg)
-> [Key (GenericPlanPackage ipkg srcpkg)]
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)

-- Alert alert!   Why does SolverId map to a LIST of plan packages?
-- The sordid story has to do with 'build-depends' on a package
-- with libraries and executables.  In an ideal world, we would
-- ONLY depend on the library in this situation.  But c.f. #3661
-- some people rely on the build-depends to ALSO implicitly
-- depend on an executable.
--
-- I don't want to commit to a strategy yet, so the only possible
-- thing you can do in this case is return EVERYTHING and let
-- the client filter out what they want (executables? libraries?
-- etc).  This similarly implies we can't return a 'ConfiguredId'
-- because that's not enough information.

fromSolverInstallPlan
  :: (IsUnit ipkg, IsUnit srcpkg)
  => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
       -> SolverInstallPlan.SolverPlanPackage
       -> [GenericPlanPackage ipkg srcpkg]
     )
  -> SolverInstallPlan
  -> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
((SolverId -> [GenericPlanPackage ipkg srcpkg])
 -> SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg]
f SolverInstallPlan
plan =
  String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan
    String
"fromSolverInstallPlan"
    ([GenericPlanPackage ipkg srcpkg]
-> Graph (GenericPlanPackage ipkg srcpkg)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList [GenericPlanPackage ipkg srcpkg]
pkgs'')
    (SolverInstallPlan -> IndependentGoals
SolverInstallPlan.planIndepGoals SolverInstallPlan
plan)
  where
    (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
_, Map UnitId [GenericPlanPackage ipkg srcpkg]
_, [GenericPlanPackage ipkg srcpkg]
pkgs'') =
      ((Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
  Map UnitId [GenericPlanPackage ipkg srcpkg],
  [GenericPlanPackage ipkg srcpkg])
 -> SolverPlanPackage
 -> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
     Map UnitId [GenericPlanPackage ipkg srcpkg],
     [GenericPlanPackage ipkg srcpkg]))
-> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
    Map UnitId [GenericPlanPackage ipkg srcpkg],
    [GenericPlanPackage ipkg srcpkg])
-> [SolverPlanPackage]
-> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
    Map UnitId [GenericPlanPackage ipkg srcpkg],
    [GenericPlanPackage ipkg srcpkg])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
 Map UnitId [GenericPlanPackage ipkg srcpkg],
 [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage
-> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
    Map UnitId [GenericPlanPackage ipkg srcpkg],
    [GenericPlanPackage ipkg srcpkg])
f'
        (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
forall k a. Map k a
Map.empty, Map UnitId [GenericPlanPackage ipkg srcpkg]
forall k a. Map k a
Map.empty, [])
        (SolverInstallPlan -> [SolverPlanPackage]
SolverInstallPlan.reverseTopologicalOrder SolverInstallPlan
plan)

    f' :: (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
 Map UnitId [GenericPlanPackage ipkg srcpkg],
 [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage
-> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
    Map UnitId [GenericPlanPackage ipkg srcpkg],
    [GenericPlanPackage ipkg srcpkg])
f' (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap, [GenericPlanPackage ipkg srcpkg]
pkgs) SolverPlanPackage
pkg = (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap', Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap', [GenericPlanPackage ipkg srcpkg]
pkgs' [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. [a] -> [a] -> [a]
++ [GenericPlanPackage ipkg srcpkg]
pkgs)
      where
        pkgs' :: [GenericPlanPackage ipkg srcpkg]
pkgs' = (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg]
f (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
-> Map UnitId [GenericPlanPackage ipkg srcpkg]
-> SolverId
-> [GenericPlanPackage ipkg srcpkg]
forall {a}.
Map PackageIdentifier a -> Map UnitId a -> SolverId -> a
mapDep Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap) SolverPlanPackage
pkg

        (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap', Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap') =
          case SolverPlanPackage -> Key SolverPlanPackage
forall a. IsNode a => a -> Key a
nodeKey SolverPlanPackage
pkg of
            PreExistingId PackageIdentifier
_ UnitId
uid -> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, UnitId
-> [GenericPlanPackage ipkg srcpkg]
-> Map UnitId [GenericPlanPackage ipkg srcpkg]
-> Map UnitId [GenericPlanPackage ipkg srcpkg]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
uid [GenericPlanPackage ipkg srcpkg]
pkgs' Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap)
            PlannedId PackageIdentifier
pid -> (PackageIdentifier
-> [GenericPlanPackage ipkg srcpkg]
-> Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
-> Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageIdentifier
pid [GenericPlanPackage ipkg srcpkg]
pkgs' Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap)

    mapDep :: Map PackageIdentifier a -> Map UnitId a -> SolverId -> a
mapDep Map PackageIdentifier a
_ Map UnitId a
ipiMap (PreExistingId PackageIdentifier
_pid UnitId
uid)
      | Just a
pkgs <- UnitId -> Map UnitId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId a
ipiMap = a
pkgs
      | Bool
otherwise = String -> a
forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PreExistingId " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
uid)
    mapDep Map PackageIdentifier a
pidMap Map UnitId a
_ (PlannedId PackageIdentifier
pid)
      | Just a
pkgs <- PackageIdentifier -> Map PackageIdentifier a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pid Map PackageIdentifier a
pidMap = a
pkgs
      | Bool
otherwise = String -> a
forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PlannedId " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pid)

-- This shouldn't happen, since mapDep should only be called
-- on neighbor SolverId, which must have all been done already
-- by the reverse top-sort (we assume the graph is not broken).

fromSolverInstallPlanWithProgress
  :: (IsUnit ipkg, IsUnit srcpkg)
  => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
       -> SolverInstallPlan.SolverPlanPackage
       -> LogProgress [GenericPlanPackage ipkg srcpkg]
     )
  -> SolverInstallPlan
  -> LogProgress (GenericInstallPlan ipkg srcpkg)
fromSolverInstallPlanWithProgress :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
((SolverId -> [GenericPlanPackage ipkg srcpkg])
 -> SolverPlanPackage
 -> LogProgress [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan
-> LogProgress (GenericInstallPlan ipkg srcpkg)
fromSolverInstallPlanWithProgress (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage
-> LogProgress [GenericPlanPackage ipkg srcpkg]
f SolverInstallPlan
plan = do
  (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
_, Map UnitId [GenericPlanPackage ipkg srcpkg]
_, [GenericPlanPackage ipkg srcpkg]
pkgs'') <-
    ((Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
  Map UnitId [GenericPlanPackage ipkg srcpkg],
  [GenericPlanPackage ipkg srcpkg])
 -> SolverPlanPackage
 -> LogProgress
      (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
       Map UnitId [GenericPlanPackage ipkg srcpkg],
       [GenericPlanPackage ipkg srcpkg]))
-> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
    Map UnitId [GenericPlanPackage ipkg srcpkg],
    [GenericPlanPackage ipkg srcpkg])
-> [SolverPlanPackage]
-> LogProgress
     (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
      Map UnitId [GenericPlanPackage ipkg srcpkg],
      [GenericPlanPackage ipkg srcpkg])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
 Map UnitId [GenericPlanPackage ipkg srcpkg],
 [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage
-> LogProgress
     (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
      Map UnitId [GenericPlanPackage ipkg srcpkg],
      [GenericPlanPackage ipkg srcpkg])
f'
      (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
forall k a. Map k a
Map.empty, Map UnitId [GenericPlanPackage ipkg srcpkg]
forall k a. Map k a
Map.empty, [])
      (SolverInstallPlan -> [SolverPlanPackage]
SolverInstallPlan.reverseTopologicalOrder SolverInstallPlan
plan)
  GenericInstallPlan ipkg srcpkg
-> LogProgress (GenericInstallPlan ipkg srcpkg)
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericInstallPlan ipkg srcpkg
 -> LogProgress (GenericInstallPlan ipkg srcpkg))
-> GenericInstallPlan ipkg srcpkg
-> LogProgress (GenericInstallPlan ipkg srcpkg)
forall a b. (a -> b) -> a -> b
$
    String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan
      String
"fromSolverInstallPlanWithProgress"
      ([GenericPlanPackage ipkg srcpkg]
-> Graph (GenericPlanPackage ipkg srcpkg)
forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList [GenericPlanPackage ipkg srcpkg]
pkgs'')
      (SolverInstallPlan -> IndependentGoals
SolverInstallPlan.planIndepGoals SolverInstallPlan
plan)
  where
    f' :: (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
 Map UnitId [GenericPlanPackage ipkg srcpkg],
 [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage
-> LogProgress
     (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
      Map UnitId [GenericPlanPackage ipkg srcpkg],
      [GenericPlanPackage ipkg srcpkg])
f' (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap, [GenericPlanPackage ipkg srcpkg]
pkgs) SolverPlanPackage
pkg = do
      [GenericPlanPackage ipkg srcpkg]
pkgs' <- (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage
-> LogProgress [GenericPlanPackage ipkg srcpkg]
f (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
-> Map UnitId [GenericPlanPackage ipkg srcpkg]
-> SolverId
-> [GenericPlanPackage ipkg srcpkg]
forall {a}.
Map PackageIdentifier a -> Map UnitId a -> SolverId -> a
mapDep Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap) SolverPlanPackage
pkg
      let (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap', Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap') =
            case SolverPlanPackage -> Key SolverPlanPackage
forall a. IsNode a => a -> Key a
nodeKey SolverPlanPackage
pkg of
              PreExistingId PackageIdentifier
_ UnitId
uid -> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, UnitId
-> [GenericPlanPackage ipkg srcpkg]
-> Map UnitId [GenericPlanPackage ipkg srcpkg]
-> Map UnitId [GenericPlanPackage ipkg srcpkg]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
uid [GenericPlanPackage ipkg srcpkg]
pkgs' Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap)
              PlannedId PackageIdentifier
pid -> (PackageIdentifier
-> [GenericPlanPackage ipkg srcpkg]
-> Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
-> Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert PackageIdentifier
pid [GenericPlanPackage ipkg srcpkg]
pkgs' Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap)
      (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
 Map UnitId [GenericPlanPackage ipkg srcpkg],
 [GenericPlanPackage ipkg srcpkg])
-> LogProgress
     (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg],
      Map UnitId [GenericPlanPackage ipkg srcpkg],
      [GenericPlanPackage ipkg srcpkg])
forall a. a -> LogProgress a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap', Map UnitId [GenericPlanPackage ipkg srcpkg]
ipiMap', [GenericPlanPackage ipkg srcpkg]
pkgs' [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. [a] -> [a] -> [a]
++ [GenericPlanPackage ipkg srcpkg]
pkgs)

    mapDep :: Map PackageIdentifier a -> Map UnitId a -> SolverId -> a
mapDep Map PackageIdentifier a
_ Map UnitId a
ipiMap (PreExistingId PackageIdentifier
_pid UnitId
uid)
      | Just a
pkgs <- UnitId -> Map UnitId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId a
ipiMap = a
pkgs
      | Bool
otherwise = String -> a
forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PreExistingId " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
uid)
    mapDep Map PackageIdentifier a
pidMap Map UnitId a
_ (PlannedId PackageIdentifier
pid)
      | Just a
pkgs <- PackageIdentifier -> Map PackageIdentifier a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pid Map PackageIdentifier a
pidMap = a
pkgs
      | Bool
otherwise = String -> a
forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PlannedId " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
pid)

-- This shouldn't happen, since mapDep should only be called
-- on neighbor SolverId, which must have all been done already
-- by the reverse top-sort (we assume the graph is not broken).

-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
-- Similar to 'elaboratedInstallPlan'
configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan
configureInstallPlan :: ConfigFlags -> SolverInstallPlan -> InstallPlan
configureInstallPlan ConfigFlags
configFlags SolverInstallPlan
solverPlan =
  (((SolverId -> [PlanPackage])
  -> SolverPlanPackage -> [PlanPackage])
 -> SolverInstallPlan -> InstallPlan)
-> SolverInstallPlan
-> ((SolverId -> [PlanPackage])
    -> SolverPlanPackage -> [PlanPackage])
-> InstallPlan
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((SolverId -> [PlanPackage]) -> SolverPlanPackage -> [PlanPackage])
-> SolverInstallPlan -> InstallPlan
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
((SolverId -> [GenericPlanPackage ipkg srcpkg])
 -> SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan SolverInstallPlan
solverPlan (((SolverId -> [PlanPackage])
  -> SolverPlanPackage -> [PlanPackage])
 -> InstallPlan)
-> ((SolverId -> [PlanPackage])
    -> SolverPlanPackage -> [PlanPackage])
-> InstallPlan
forall a b. (a -> b) -> a -> b
$ \SolverId -> [PlanPackage]
mapDep SolverPlanPackage
planpkg ->
    [ case SolverPlanPackage
planpkg of
        SolverInstallPlan.PreExisting InstSolverPackage
pkg ->
          InstalledPackageInfo -> PlanPackage
forall ipkg srcpkg. ipkg -> GenericPlanPackage ipkg srcpkg
PreExisting (InstSolverPackage -> InstalledPackageInfo
instSolverPkgIPI InstSolverPackage
pkg)
        SolverInstallPlan.Configured SolverPackage UnresolvedPkgLoc
pkg ->
          ConfiguredPackage UnresolvedPkgLoc -> PlanPackage
forall ipkg srcpkg. srcpkg -> GenericPlanPackage ipkg srcpkg
Configured ((SolverId -> [PlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> ConfiguredPackage UnresolvedPkgLoc
configureSolverPackage SolverId -> [PlanPackage]
mapDep SolverPackage UnresolvedPkgLoc
pkg)
    ]
  where
    configureSolverPackage
      :: (SolverId -> [PlanPackage])
      -> SolverPackage UnresolvedPkgLoc
      -> ConfiguredPackage UnresolvedPkgLoc
    configureSolverPackage :: (SolverId -> [PlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> ConfiguredPackage UnresolvedPkgLoc
configureSolverPackage SolverId -> [PlanPackage]
mapDep SolverPackage UnresolvedPkgLoc
spkg =
      ConfiguredPackage
        { confPkgId :: InstalledPackageId
confPkgId =
            Bool
-> Flag String
-> Flag InstalledPackageId
-> PackageIdentifier
-> ComponentName
-> Maybe ([InstalledPackageId], FlagAssignment)
-> InstalledPackageId
Configure.computeComponentId
              ( Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
Cabal.fromFlagOrDefault
                  Bool
False
                  (ConfigFlags -> Flag Bool
Cabal.configDeterministic ConfigFlags
configFlags)
              )
              Flag String
forall a. Flag a
Cabal.NoFlag
              Flag InstalledPackageId
forall a. Flag a
Cabal.NoFlag
              (SolverPackage UnresolvedPkgLoc -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId SolverPackage UnresolvedPkgLoc
spkg)
              (LibraryName -> ComponentName
PD.CLibName LibraryName
PD.LMainLibName)
              ( ([InstalledPackageId], FlagAssignment)
-> Maybe ([InstalledPackageId], FlagAssignment)
forall a. a -> Maybe a
Just
                  ( (ConfiguredId -> InstalledPackageId)
-> [ConfiguredId] -> [InstalledPackageId]
forall a b. (a -> b) -> [a] -> [b]
map ConfiguredId -> InstalledPackageId
confInstId (ComponentDeps [ConfiguredId] -> [ConfiguredId]
forall a. Monoid a => ComponentDeps a -> a
CD.libraryDeps ComponentDeps [ConfiguredId]
deps)
                  , SolverPackage UnresolvedPkgLoc -> FlagAssignment
forall loc. SolverPackage loc -> FlagAssignment
solverPkgFlags SolverPackage UnresolvedPkgLoc
spkg
                  )
              )
        , confPkgSource :: SourcePackage UnresolvedPkgLoc
confPkgSource = SolverPackage UnresolvedPkgLoc -> SourcePackage UnresolvedPkgLoc
forall loc. SolverPackage loc -> SourcePackage loc
solverPkgSource SolverPackage UnresolvedPkgLoc
spkg
        , confPkgFlags :: FlagAssignment
confPkgFlags = SolverPackage UnresolvedPkgLoc -> FlagAssignment
forall loc. SolverPackage loc -> FlagAssignment
solverPkgFlags SolverPackage UnresolvedPkgLoc
spkg
        , confPkgStanzas :: OptionalStanzaSet
confPkgStanzas = SolverPackage UnresolvedPkgLoc -> OptionalStanzaSet
forall loc. SolverPackage loc -> OptionalStanzaSet
solverPkgStanzas SolverPackage UnresolvedPkgLoc
spkg
        , confPkgDeps :: ComponentDeps [ConfiguredId]
confPkgDeps = ComponentDeps [ConfiguredId]
deps
        -- NB: no support for executable dependencies
        }
      where
        deps :: ComponentDeps [ConfiguredId]
deps = ([SolverId] -> [ConfiguredId])
-> ComponentDeps [SolverId] -> ComponentDeps [ConfiguredId]
forall a b. (a -> b) -> ComponentDeps a -> ComponentDeps b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SolverId -> [ConfiguredId]) -> [SolverId] -> [ConfiguredId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((PlanPackage -> ConfiguredId) -> [PlanPackage] -> [ConfiguredId]
forall a b. (a -> b) -> [a] -> [b]
map PlanPackage -> ConfiguredId
forall a. HasConfiguredId a => a -> ConfiguredId
configuredId ([PlanPackage] -> [ConfiguredId])
-> (SolverId -> [PlanPackage]) -> SolverId -> [ConfiguredId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverId -> [PlanPackage]
mapDep)) (SolverPackage UnresolvedPkgLoc -> ComponentDeps [SolverId]
forall loc. SolverPackage loc -> ComponentDeps [SolverId]
solverPkgLibDeps SolverPackage UnresolvedPkgLoc
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
  :: (IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> ([GenericReadyPackage srcpkg], Processing)
ready :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
ready GenericInstallPlan ipkg srcpkg
plan =
  Bool
-> ([GenericReadyPackage srcpkg], Processing)
-> ([GenericReadyPackage srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (GenericInstallPlan ipkg srcpkg -> Processing -> Bool
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan Processing
processing) (([GenericReadyPackage srcpkg], Processing)
 -> ([GenericReadyPackage srcpkg], Processing))
-> ([GenericReadyPackage srcpkg], Processing)
-> ([GenericReadyPackage srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
    ([GenericReadyPackage srcpkg]
readyPackages, Processing
processing)
  where
    !processing :: Processing
processing =
      Set UnitId -> Set UnitId -> Set UnitId -> Processing
Processing
        ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [GenericReadyPackage srcpkg -> Key (GenericReadyPackage srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericReadyPackage srcpkg
pkg | GenericReadyPackage srcpkg
pkg <- [GenericReadyPackage srcpkg]
readyPackages])
        ([UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg | GenericPlanPackage ipkg srcpkg
pkg <- GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
toList GenericInstallPlan ipkg srcpkg
plan, GenericPlanPackage ipkg srcpkg -> Bool
forall a b. GenericPlanPackage a b -> Bool
isInstalled GenericPlanPackage ipkg srcpkg
pkg])
        Set UnitId
forall a. Set a
Set.empty
    readyPackages :: [GenericReadyPackage srcpkg]
readyPackages =
      [ srcpkg -> GenericReadyPackage srcpkg
forall srcpkg. srcpkg -> GenericReadyPackage srcpkg
ReadyPackage srcpkg
pkg
      | Configured srcpkg
pkg <- GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
toList GenericInstallPlan ipkg srcpkg
plan
      , (GenericPlanPackage ipkg srcpkg -> Bool)
-> [GenericPlanPackage ipkg srcpkg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all GenericPlanPackage ipkg srcpkg -> Bool
forall a b. GenericPlanPackage a b -> Bool
isInstalled (GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan (srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
pkg))
      ]

isInstalled :: GenericPlanPackage a b -> Bool
isInstalled :: forall a b. GenericPlanPackage a b -> Bool
isInstalled (PreExisting{}) = Bool
True
isInstalled (Installed{}) = Bool
True
isInstalled GenericPlanPackage a b
_ = Bool
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
  :: forall ipkg srcpkg
   . (IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> Processing
  -> UnitId
  -> ([GenericReadyPackage srcpkg], Processing)
completed :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> Processing
-> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
completed GenericInstallPlan ipkg srcpkg
plan (Processing Set UnitId
processingSet Set UnitId
completedSet Set UnitId
failedSet) UnitId
pkgid =
  Bool
-> ([GenericReadyPackage srcpkg], Processing)
-> ([GenericReadyPackage srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (UnitId
pkgid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
processingSet) (([GenericReadyPackage srcpkg], Processing)
 -> ([GenericReadyPackage srcpkg], Processing))
-> ([GenericReadyPackage srcpkg], Processing)
-> ([GenericReadyPackage srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
    Bool
-> ([GenericReadyPackage srcpkg], Processing)
-> ([GenericReadyPackage srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (GenericInstallPlan ipkg srcpkg -> Processing -> Bool
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan Processing
processing') (([GenericReadyPackage srcpkg], Processing)
 -> ([GenericReadyPackage srcpkg], Processing))
-> ([GenericReadyPackage srcpkg], Processing)
-> ([GenericReadyPackage srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
      ( (GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg)
-> [GenericPlanPackage ipkg srcpkg] -> [GenericReadyPackage srcpkg]
forall a b. (a -> b) -> [a] -> [b]
map GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg
asReadyPackage [GenericPlanPackage ipkg srcpkg]
newlyReady
      , Processing
processing'
      )
  where
    completedSet' :: Set UnitId
completedSet' = UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
pkgid Set UnitId
completedSet

    -- each direct reverse dep where all direct deps are completed
    newlyReady :: [GenericPlanPackage ipkg srcpkg]
newlyReady =
      [ GenericPlanPackage ipkg srcpkg
dep
      | GenericPlanPackage ipkg srcpkg
dep <- GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
revDirectDeps GenericInstallPlan ipkg srcpkg
plan UnitId
pkgid
      , (GenericPlanPackage ipkg srcpkg -> Bool)
-> [GenericPlanPackage ipkg srcpkg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
          ((UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
completedSet') (UnitId -> Bool)
-> (GenericPlanPackage ipkg srcpkg -> UnitId)
-> GenericPlanPackage ipkg srcpkg
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey)
          (GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan (GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
dep))
      ]

    processingSet' :: Set UnitId
processingSet' =
      (Set UnitId -> UnitId -> Set UnitId)
-> Set UnitId -> [UnitId] -> Set UnitId
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        ((UnitId -> Set UnitId -> Set UnitId)
-> Set UnitId -> UnitId -> Set UnitId
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert)
        (UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.delete UnitId
pkgid Set UnitId
processingSet)
        ((GenericPlanPackage ipkg srcpkg -> UnitId)
-> [GenericPlanPackage ipkg srcpkg] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey [GenericPlanPackage ipkg srcpkg]
newlyReady)
    processing' :: Processing
processing' = Set UnitId -> Set UnitId -> Set UnitId -> Processing
Processing Set UnitId
processingSet' Set UnitId
completedSet' Set UnitId
failedSet

    asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg
    asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg
asReadyPackage (Configured srcpkg
pkg) = srcpkg -> GenericReadyPackage srcpkg
forall srcpkg. srcpkg -> GenericReadyPackage srcpkg
ReadyPackage srcpkg
pkg
    asReadyPackage GenericPlanPackage ipkg srcpkg
pkg = String -> String -> GenericReadyPackage srcpkg
forall a. WithCallStack (String -> String -> a)
internalError String
"completed" (String -> GenericReadyPackage srcpkg)
-> String -> GenericReadyPackage srcpkg
forall a b. (a -> b) -> a -> b
$ String
"not in configured state: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GenericPlanPackage ipkg srcpkg -> String
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericPlanPackage ipkg srcpkg -> String
displayGenericPlanPackage GenericPlanPackage ipkg srcpkg
pkg

failed
  :: (IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> Processing
  -> UnitId
  -> ([srcpkg], Processing)
failed :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId -> ([srcpkg], Processing)
failed GenericInstallPlan ipkg srcpkg
plan (Processing Set UnitId
processingSet Set UnitId
completedSet Set UnitId
failedSet) UnitId
pkgid =
  Bool -> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (UnitId
pkgid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
processingSet) (([srcpkg], Processing) -> ([srcpkg], Processing))
-> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
    Bool -> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((UnitId -> Bool) -> [UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
processingSet) (Int -> [UnitId] -> [UnitId]
forall a. Int -> [a] -> [a]
drop Int
1 [UnitId]
newlyFailedIds)) (([srcpkg], Processing) -> ([srcpkg], Processing))
-> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
      Bool -> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((UnitId -> Bool) -> [UnitId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
completedSet) (Int -> [UnitId] -> [UnitId]
forall a. Int -> [a] -> [a]
drop Int
1 [UnitId]
newlyFailedIds)) (([srcpkg], Processing) -> ([srcpkg], Processing))
-> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
        -- but note that some newlyFailed may already be in the failed set
        -- since one package can depend on two packages that both fail and
        -- so would be in the rev-dep closure for both.
        Bool -> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (GenericInstallPlan ipkg srcpkg -> Processing -> Bool
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan Processing
processing') (([srcpkg], Processing) -> ([srcpkg], Processing))
-> ([srcpkg], Processing) -> ([srcpkg], Processing)
forall a b. (a -> b) -> a -> b
$
          ( (GenericPlanPackage ipkg srcpkg -> srcpkg)
-> [GenericPlanPackage ipkg srcpkg] -> [srcpkg]
forall a b. (a -> b) -> [a] -> [b]
map GenericPlanPackage ipkg srcpkg -> srcpkg
forall {ipkg} {srcpkg}.
(Key ipkg ~ UnitId, Key srcpkg ~ UnitId, IsNode ipkg,
 IsNode srcpkg) =>
GenericPlanPackage ipkg srcpkg -> srcpkg
asConfiguredPackage (Int
-> [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. Int -> [a] -> [a]
drop Int
1 [GenericPlanPackage ipkg srcpkg]
newlyFailed)
          , Processing
processing'
          )
  where
    processingSet' :: Set UnitId
processingSet' = UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.delete UnitId
pkgid Set UnitId
processingSet
    failedSet' :: Set UnitId
failedSet' = Set UnitId
failedSet Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
newlyFailedIds
    newlyFailedIds :: [UnitId]
newlyFailedIds = (GenericPlanPackage ipkg srcpkg -> UnitId)
-> [GenericPlanPackage ipkg srcpkg] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey [GenericPlanPackage ipkg srcpkg]
newlyFailed
    newlyFailed :: [GenericPlanPackage ipkg srcpkg]
newlyFailed =
      [GenericPlanPackage ipkg srcpkg]
-> Maybe [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. a -> Maybe a -> a
fromMaybe (String -> String -> [GenericPlanPackage ipkg srcpkg]
forall a. WithCallStack (String -> String -> a)
internalError String
"failed" String
"package not in graph") (Maybe [GenericPlanPackage ipkg srcpkg]
 -> [GenericPlanPackage ipkg srcpkg])
-> Maybe [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a b. (a -> b) -> a -> b
$
        Graph (GenericPlanPackage ipkg srcpkg)
-> [Key (GenericPlanPackage ipkg srcpkg)]
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) [UnitId
Key (GenericPlanPackage ipkg srcpkg)
pkgid]
    processing' :: Processing
processing' = Set UnitId -> Set UnitId -> Set UnitId -> Processing
Processing Set UnitId
processingSet' Set UnitId
completedSet Set UnitId
failedSet'

    asConfiguredPackage :: GenericPlanPackage ipkg srcpkg -> srcpkg
asConfiguredPackage (Configured srcpkg
pkg) = srcpkg
pkg
    asConfiguredPackage GenericPlanPackage ipkg srcpkg
pkg = String -> String -> srcpkg
forall a. WithCallStack (String -> String -> a)
internalError String
"failed" (String -> srcpkg) -> String -> srcpkg
forall a b. (a -> b) -> a -> b
$ String
"not in configured state: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ GenericPlanPackage ipkg srcpkg -> String
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericPlanPackage ipkg srcpkg -> String
displayGenericPlanPackage GenericPlanPackage ipkg srcpkg
pkg

processingInvariant
  :: (IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> Processing
  -> Bool
processingInvariant :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan (Processing Set UnitId
processingSet Set UnitId
completedSet Set UnitId
failedSet) =
  -- All the packages in the three sets are actually in the graph
  Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((UnitId -> Bool) -> Set UnitId -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.all ((UnitId -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool)
-> Graph (GenericPlanPackage ipkg srcpkg) -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
forall a. IsNode a => Key a -> Graph a -> Bool
Graph.member (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)) Set UnitId
processingSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((UnitId -> Bool) -> Set UnitId -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.all ((UnitId -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool)
-> Graph (GenericPlanPackage ipkg srcpkg) -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
forall a. IsNode a => Key a -> Graph a -> Bool
Graph.member (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)) Set UnitId
completedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert ((UnitId -> Bool) -> Set UnitId -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.all ((UnitId -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool)
-> Graph (GenericPlanPackage ipkg srcpkg) -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
forall a. IsNode a => Key a -> Graph a -> Bool
Graph.member (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)) Set UnitId
failedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    -- The processing, completed and failed sets are disjoint from each other
    Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set UnitId -> Set UnitId -> Bool
forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection Set UnitId
processingSet Set UnitId
completedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set UnitId -> Set UnitId -> Bool
forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection Set UnitId
processingSet Set UnitId
failedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set UnitId -> Set UnitId -> Bool
forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection Set UnitId
failedSet Set UnitId
completedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    -- Packages that depend on a package that's still processing cannot be
    -- completed
    Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set UnitId -> Set UnitId -> Bool
forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection (Set UnitId -> Set UnitId
reverseClosure Set UnitId
processingSet) Set UnitId
completedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    -- On the other hand, packages that depend on a package that's still
    -- processing /can/ have failed (since they may have depended on multiple
    -- packages that were processing, but it only takes one to fail to cause
    -- knock-on failures) so it is quite possible to have an
    -- intersection (reverseClosure processingSet) failedSet

    -- The failed set is upwards closed, i.e. equal to its own rev dep closure
    Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set UnitId
failedSet Set UnitId -> Set UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== Set UnitId -> Set UnitId
reverseClosure Set UnitId
failedSet)
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    -- All immediate reverse deps of packages that are currently processing
    -- are not currently being processed (ie not in the processing set).
    Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert
      ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
          [ UnitId
rdeppkgid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
processingSet
          | UnitId
pkgid <- Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
processingSet
          , UnitId
rdeppkgid <-
              [UnitId]
-> ([GenericPlanPackage ipkg srcpkg] -> [UnitId])
-> Maybe [GenericPlanPackage ipkg srcpkg]
-> [UnitId]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (String -> String -> [UnitId]
forall a. WithCallStack (String -> String -> a)
internalError String
"processingInvariant" String
"")
                ((GenericPlanPackage ipkg srcpkg -> UnitId)
-> [GenericPlanPackage ipkg srcpkg] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey)
                (Graph (GenericPlanPackage ipkg srcpkg)
-> Key (GenericPlanPackage ipkg srcpkg)
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> Key a -> Maybe [a]
Graph.revNeighbors (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) UnitId
Key (GenericPlanPackage ipkg srcpkg)
pkgid)
          ]
      )
    (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
    -- Packages from the processing or failed sets are only ever in the
    -- configured state.
    Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert
      ( [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
          [ case Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup UnitId
Key (GenericPlanPackage ipkg srcpkg)
pkgid (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) of
            Just (Configured srcpkg
_) -> Bool
True
            Just (PreExisting ipkg
_) -> Bool
False
            Just (Installed srcpkg
_) -> Bool
False
            Maybe (GenericPlanPackage ipkg srcpkg)
Nothing -> Bool
False
          | UnitId
pkgid <- Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
processingSet [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
failedSet
          ]
      )
      -- We use asserts rather than returning False so that on failure we get
      -- better details on which bit of the invariant was violated.
      Bool
True
  where
    reverseClosure :: Set UnitId -> Set UnitId
reverseClosure =
      [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList
        ([UnitId] -> Set UnitId)
-> (Set UnitId -> [UnitId]) -> Set UnitId -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericPlanPackage ipkg srcpkg -> UnitId)
-> [GenericPlanPackage ipkg srcpkg] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey
        ([GenericPlanPackage ipkg srcpkg] -> [UnitId])
-> (Set UnitId -> [GenericPlanPackage ipkg srcpkg])
-> Set UnitId
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenericPlanPackage ipkg srcpkg]
-> Maybe [GenericPlanPackage ipkg srcpkg]
-> [GenericPlanPackage ipkg srcpkg]
forall a. a -> Maybe a -> a
fromMaybe (String -> String -> [GenericPlanPackage ipkg srcpkg]
forall a. WithCallStack (String -> String -> a)
internalError String
"processingInvariant" String
"")
        (Maybe [GenericPlanPackage ipkg srcpkg]
 -> [GenericPlanPackage ipkg srcpkg])
-> (Set UnitId -> Maybe [GenericPlanPackage ipkg srcpkg])
-> Set UnitId
-> [GenericPlanPackage ipkg srcpkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph (GenericPlanPackage ipkg srcpkg)
-> [Key (GenericPlanPackage ipkg srcpkg)]
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure (GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)
        ([UnitId] -> Maybe [GenericPlanPackage ipkg srcpkg])
-> (Set UnitId -> [UnitId])
-> Set UnitId
-> Maybe [GenericPlanPackage ipkg srcpkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList
    noIntersection :: Set a -> Set a -> Bool
noIntersection Set a
a Set a
b = Set a -> Bool
forall a. Set a -> Bool
Set.null (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
a Set 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 simulations 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
  :: (IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> [GenericReadyPackage srcpkg]
executionOrder :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg]
executionOrder GenericInstallPlan ipkg srcpkg
plan =
  let ([GenericReadyPackage srcpkg]
newpkgs, Processing
processing) = GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
ready GenericInstallPlan ipkg srcpkg
plan
   in Processing
-> [GenericReadyPackage srcpkg] -> [GenericReadyPackage srcpkg]
tryNewTasks Processing
processing [GenericReadyPackage srcpkg]
newpkgs
  where
    tryNewTasks :: Processing
-> [GenericReadyPackage srcpkg] -> [GenericReadyPackage srcpkg]
tryNewTasks Processing
_processing [] = []
    tryNewTasks Processing
processing (GenericReadyPackage srcpkg
p : [GenericReadyPackage srcpkg]
todo) = Processing
-> GenericReadyPackage srcpkg
-> [GenericReadyPackage srcpkg]
-> [GenericReadyPackage srcpkg]
waitForTasks Processing
processing GenericReadyPackage srcpkg
p [GenericReadyPackage srcpkg]
todo

    waitForTasks :: Processing
-> GenericReadyPackage srcpkg
-> [GenericReadyPackage srcpkg]
-> [GenericReadyPackage srcpkg]
waitForTasks Processing
processing GenericReadyPackage srcpkg
p [GenericReadyPackage srcpkg]
todo =
      GenericReadyPackage srcpkg
p GenericReadyPackage srcpkg
-> [GenericReadyPackage srcpkg] -> [GenericReadyPackage srcpkg]
forall a. a -> [a] -> [a]
: Processing
-> [GenericReadyPackage srcpkg] -> [GenericReadyPackage srcpkg]
tryNewTasks Processing
processing' ([GenericReadyPackage srcpkg]
todo [GenericReadyPackage srcpkg]
-> [GenericReadyPackage srcpkg] -> [GenericReadyPackage srcpkg]
forall a. [a] -> [a] -> [a]
++ [GenericReadyPackage srcpkg]
nextpkgs)
      where
        ([GenericReadyPackage srcpkg]
nextpkgs, Processing
processing') = GenericInstallPlan ipkg srcpkg
-> Processing
-> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> Processing
-> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
completed GenericInstallPlan ipkg srcpkg
plan Processing
processing (GenericReadyPackage srcpkg -> Key (GenericReadyPackage srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericReadyPackage srcpkg
p)

-- ------------------------------------------------------------

-- * Executing plans

-- ------------------------------------------------------------

-- | The set of results we get from executing an install plan.
type BuildOutcomes failure result = Map UnitId (Either failure result)

-- | Lookup the build result for a single package.
lookupBuildOutcome
  :: HasUnitId pkg
  => pkg
  -> BuildOutcomes failure result
  -> Maybe (Either failure result)
lookupBuildOutcome :: forall pkg failure result.
HasUnitId pkg =>
pkg
-> BuildOutcomes failure result -> Maybe (Either failure result)
lookupBuildOutcome = UnitId
-> Map UnitId (Either failure result)
-> Maybe (Either failure result)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (UnitId
 -> Map UnitId (Either failure result)
 -> Maybe (Either failure result))
-> (pkg -> UnitId)
-> pkg
-> Map UnitId (Either failure result)
-> Maybe (Either failure result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pkg -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
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 'BuildOutcomes' 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.
--
-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages
-- in the plan. In particular in the default mode where we stop as soon as
-- possible after a failure then there may be packages which are skipped and
-- these will have no 'BuildOutcome'.
execute
  :: forall m ipkg srcpkg result failure
   . ( IsUnit ipkg
     , IsUnit 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 (BuildOutcomes failure result)
execute :: forall (m :: * -> *) ipkg srcpkg result failure.
(IsUnit ipkg, IsUnit srcpkg, Monad m) =>
JobControl m (UnitId, Either failure result)
-> Bool
-> (srcpkg -> failure)
-> GenericInstallPlan ipkg srcpkg
-> (GenericReadyPackage srcpkg -> m (Either failure result))
-> m (BuildOutcomes failure result)
execute JobControl m (UnitId, Either failure result)
jobCtl Bool
keepGoing srcpkg -> failure
depFailure GenericInstallPlan ipkg srcpkg
plan GenericReadyPackage srcpkg -> m (Either failure result)
installPkg =
  let ([GenericReadyPackage srcpkg]
newpkgs, Processing
processing) = GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> ([GenericReadyPackage srcpkg], Processing)
ready GenericInstallPlan ipkg srcpkg
plan
   in BuildOutcomes failure result
-> Bool
-> Bool
-> Processing
-> [GenericReadyPackage srcpkg]
-> m (BuildOutcomes failure result)
tryNewTasks BuildOutcomes failure result
forall k a. Map k a
Map.empty Bool
False Bool
False Processing
processing [GenericReadyPackage srcpkg]
newpkgs
  where
    tryNewTasks
      :: BuildOutcomes failure result
      -> Bool
      -> Bool
      -> Processing
      -> [GenericReadyPackage srcpkg]
      -> m (BuildOutcomes failure result)

    tryNewTasks :: BuildOutcomes failure result
-> Bool
-> Bool
-> Processing
-> [GenericReadyPackage srcpkg]
-> m (BuildOutcomes failure result)
tryNewTasks !BuildOutcomes failure result
results Bool
tasksFailed Bool
tasksRemaining !Processing
processing [GenericReadyPackage srcpkg]
newpkgs
      -- we were in the process of cancelling and now we're finished
      | Bool
tasksFailed Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
keepGoing Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tasksRemaining =
          BuildOutcomes failure result -> m (BuildOutcomes failure result)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcomes failure result
results
      -- we are still in the process of cancelling, wait for remaining tasks
      | Bool
tasksFailed Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
keepGoing Bool -> Bool -> Bool
&& Bool
tasksRemaining =
          BuildOutcomes failure result
-> Bool -> Processing -> m (BuildOutcomes failure result)
waitForTasks BuildOutcomes failure result
results Bool
tasksFailed Processing
processing
      -- no new tasks to do and all tasks are done so we're finished
      | [GenericReadyPackage srcpkg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage srcpkg]
newpkgs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tasksRemaining =
          BuildOutcomes failure result -> m (BuildOutcomes failure result)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcomes failure result
results
      -- no new tasks to do, remaining tasks to wait for
      | [GenericReadyPackage srcpkg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage srcpkg]
newpkgs =
          BuildOutcomes failure result
-> Bool -> Processing -> m (BuildOutcomes failure result)
waitForTasks BuildOutcomes failure result
results Bool
tasksFailed Processing
processing
      -- new tasks to do, spawn them, then wait for tasks to complete
      | Bool
otherwise =
          do
            [m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
              [ JobControl m (UnitId, Either failure result)
-> m (UnitId, Either failure result) -> m ()
forall (m :: * -> *) a. JobControl m a -> m a -> m ()
spawnJob JobControl m (UnitId, Either failure result)
jobCtl (m (UnitId, Either failure result) -> m ())
-> m (UnitId, Either failure result) -> m ()
forall a b. (a -> b) -> a -> b
$ do
                Either failure result
result <- GenericReadyPackage srcpkg -> m (Either failure result)
installPkg GenericReadyPackage srcpkg
pkg
                (UnitId, Either failure result)
-> m (UnitId, Either failure result)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericReadyPackage srcpkg -> Key (GenericReadyPackage srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericReadyPackage srcpkg
pkg, Either failure result
result)
              | GenericReadyPackage srcpkg
pkg <- [GenericReadyPackage srcpkg]
newpkgs
              ]
            BuildOutcomes failure result
-> Bool -> Processing -> m (BuildOutcomes failure result)
waitForTasks BuildOutcomes failure result
results Bool
tasksFailed Processing
processing

    waitForTasks
      :: BuildOutcomes failure result
      -> Bool
      -> Processing
      -> m (BuildOutcomes failure result)
    waitForTasks :: BuildOutcomes failure result
-> Bool -> Processing -> m (BuildOutcomes failure result)
waitForTasks !BuildOutcomes failure result
results Bool
tasksFailed !Processing
processing = do
      (UnitId
pkgid, Either failure result
result) <- JobControl m (UnitId, Either failure result)
-> m (UnitId, Either failure result)
forall (m :: * -> *) a. JobControl m a -> m a
collectJob JobControl m (UnitId, Either failure result)
jobCtl

      case Either failure result
result of
        Right result
_success -> do
          Bool
tasksRemaining <- JobControl m (UnitId, Either failure result) -> m Bool
forall (m :: * -> *) a. JobControl m a -> m Bool
remainingJobs JobControl m (UnitId, Either failure result)
jobCtl
          BuildOutcomes failure result
-> Bool
-> Bool
-> Processing
-> [GenericReadyPackage srcpkg]
-> m (BuildOutcomes failure result)
tryNewTasks
            BuildOutcomes failure result
results'
            Bool
tasksFailed
            Bool
tasksRemaining
            Processing
processing'
            [GenericReadyPackage srcpkg]
nextpkgs
          where
            results' :: BuildOutcomes failure result
results' = UnitId
-> Either failure result
-> BuildOutcomes failure result
-> BuildOutcomes failure result
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
pkgid Either failure result
result BuildOutcomes failure result
results
            ([GenericReadyPackage srcpkg]
nextpkgs, Processing
processing') = GenericInstallPlan ipkg srcpkg
-> Processing
-> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> Processing
-> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
completed GenericInstallPlan ipkg srcpkg
plan Processing
processing UnitId
pkgid
        Left failure
_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
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
tasksFailed Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
keepGoing) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            JobControl m (UnitId, Either failure result) -> m ()
forall (m :: * -> *) a. JobControl m a -> m ()
cancelJobs JobControl m (UnitId, Either failure result)
jobCtl

          Bool
tasksRemaining <- JobControl m (UnitId, Either failure result) -> m Bool
forall (m :: * -> *) a. JobControl m a -> m Bool
remainingJobs JobControl m (UnitId, Either failure result)
jobCtl
          BuildOutcomes failure result
-> Bool
-> Bool
-> Processing
-> [GenericReadyPackage srcpkg]
-> m (BuildOutcomes failure result)
tryNewTasks BuildOutcomes failure result
results' Bool
True Bool
tasksRemaining Processing
processing' []
          where
            ([srcpkg]
depsfailed, Processing
processing') = GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId -> ([srcpkg], Processing)
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> Processing -> UnitId -> ([srcpkg], Processing)
failed GenericInstallPlan ipkg srcpkg
plan Processing
processing UnitId
pkgid
            results' :: BuildOutcomes failure result
results' = UnitId
-> Either failure result
-> BuildOutcomes failure result
-> BuildOutcomes failure result
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert UnitId
pkgid Either failure result
result BuildOutcomes failure result
results BuildOutcomes failure result
-> BuildOutcomes failure result -> BuildOutcomes failure result
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` BuildOutcomes failure result
depResults
            depResults :: BuildOutcomes failure result
depResults =
              [(UnitId, Either failure result)] -> BuildOutcomes failure result
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ (srcpkg -> Key srcpkg
forall a. IsNode a => a -> Key a
nodeKey srcpkg
deppkg, failure -> Either failure result
forall a b. a -> Either a b
Left (srcpkg -> failure
depFailure srcpkg
deppkg))
                | srcpkg
deppkg <- [srcpkg]
depsfailed
                ]

-- ------------------------------------------------------------

-- * Checking validity of plans

-- ------------------------------------------------------------

-- | A valid installation plan is a set of packages that is closed, acyclic
-- and respects the package state relation.
--
-- * if the result is @False@ use 'problems' to get a detailed list.
valid
  :: (IsUnit ipkg, IsUnit srcpkg)
  => String
  -> Graph (GenericPlanPackage ipkg srcpkg)
  -> Bool
valid :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
valid String
loc Graph (GenericPlanPackage ipkg srcpkg)
graph =
  case Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg]
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg]
problems Graph (GenericPlanPackage ipkg srcpkg)
graph of
    [] -> Bool
True
    [PlanProblem ipkg srcpkg]
ps -> String -> String -> Bool
forall a. WithCallStack (String -> String -> a)
internalError String
loc (Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
unlines ((PlanProblem ipkg srcpkg -> String)
-> [PlanProblem ipkg srcpkg] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PlanProblem ipkg srcpkg -> String
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
PlanProblem ipkg srcpkg -> String
showPlanProblem [PlanProblem ipkg srcpkg]
ps))

data PlanProblem ipkg srcpkg
  = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
  | PackageCycle [GenericPlanPackage ipkg srcpkg]
  | PackageStateInvalid
      (GenericPlanPackage ipkg srcpkg)
      (GenericPlanPackage ipkg srcpkg)

showPlanProblem
  :: (IsUnit ipkg, IsUnit srcpkg)
  => PlanProblem ipkg srcpkg
  -> String
showPlanProblem :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
PlanProblem ipkg srcpkg -> String
showPlanProblem (PackageMissingDeps GenericPlanPackage ipkg srcpkg
pkg [UnitId]
missingDeps) =
  String
"Package "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg)
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" depends on the following packages which are missing from the plan: "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((UnitId -> String) -> [UnitId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> String
forall a. Pretty a => a -> String
prettyShow [UnitId]
missingDeps)
showPlanProblem (PackageCycle [GenericPlanPackage ipkg srcpkg]
cycleGroup) =
  String
"The following packages are involved in a dependency cycle "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((GenericPlanPackage ipkg srcpkg -> String)
-> [GenericPlanPackage ipkg srcpkg] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> String
forall a. Pretty a => a -> String
prettyShow (UnitId -> String)
-> (GenericPlanPackage ipkg srcpkg -> UnitId)
-> GenericPlanPackage ipkg srcpkg
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey) [GenericPlanPackage ipkg srcpkg]
cycleGroup)
showPlanProblem (PackageStateInvalid GenericPlanPackage ipkg srcpkg
pkg GenericPlanPackage ipkg srcpkg
pkg') =
  String
"Package "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg)
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is in the "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ GenericPlanPackage ipkg srcpkg -> String
forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag GenericPlanPackage ipkg srcpkg
pkg
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" state but it depends on package "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow (GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg')
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" which is in the "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ GenericPlanPackage ipkg srcpkg -> String
forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag GenericPlanPackage ipkg srcpkg
pkg'
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" state"

-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
problems
  :: (IsUnit ipkg, IsUnit srcpkg)
  => Graph (GenericPlanPackage ipkg srcpkg)
  -> [PlanProblem ipkg srcpkg]
problems :: forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
Graph (GenericPlanPackage ipkg srcpkg) -> [PlanProblem ipkg srcpkg]
problems Graph (GenericPlanPackage ipkg srcpkg)
graph =
  [ GenericPlanPackage ipkg srcpkg
-> [UnitId] -> PlanProblem ipkg srcpkg
forall ipkg srcpkg.
GenericPlanPackage ipkg srcpkg
-> [UnitId] -> PlanProblem ipkg srcpkg
PackageMissingDeps
    GenericPlanPackage ipkg srcpkg
pkg
    ( (UnitId -> Maybe UnitId) -> [UnitId] -> [UnitId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ((GenericPlanPackage ipkg srcpkg -> UnitId)
-> Maybe (GenericPlanPackage ipkg srcpkg) -> Maybe UnitId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenericPlanPackage ipkg srcpkg -> UnitId
GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey (Maybe (GenericPlanPackage ipkg srcpkg) -> Maybe UnitId)
-> (UnitId -> Maybe (GenericPlanPackage ipkg srcpkg))
-> UnitId
-> Maybe UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId
 -> Graph (GenericPlanPackage ipkg srcpkg)
 -> Maybe (GenericPlanPackage ipkg srcpkg))
-> Graph (GenericPlanPackage ipkg srcpkg)
-> UnitId
-> Maybe (GenericPlanPackage ipkg srcpkg)
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId
-> Graph (GenericPlanPackage ipkg srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup Graph (GenericPlanPackage ipkg srcpkg)
graph)
        [UnitId]
missingDeps
    )
  | (GenericPlanPackage ipkg srcpkg
pkg, [UnitId]
missingDeps) <- Graph (GenericPlanPackage ipkg srcpkg)
-> [(GenericPlanPackage ipkg srcpkg,
     [Key (GenericPlanPackage ipkg srcpkg)])]
forall a. Graph a -> [(a, [Key a])]
Graph.broken Graph (GenericPlanPackage ipkg srcpkg)
graph
  ]
    [PlanProblem ipkg srcpkg]
-> [PlanProblem ipkg srcpkg] -> [PlanProblem ipkg srcpkg]
forall a. [a] -> [a] -> [a]
++ [ [GenericPlanPackage ipkg srcpkg] -> PlanProblem ipkg srcpkg
forall ipkg srcpkg.
[GenericPlanPackage ipkg srcpkg] -> PlanProblem ipkg srcpkg
PackageCycle [GenericPlanPackage ipkg srcpkg]
cycleGroup
       | [GenericPlanPackage ipkg srcpkg]
cycleGroup <- Graph (GenericPlanPackage ipkg srcpkg)
-> [[GenericPlanPackage ipkg srcpkg]]
forall a. Graph a -> [[a]]
Graph.cycles Graph (GenericPlanPackage ipkg srcpkg)
graph
       ]
    {-
      ++ [ PackageInconsistency name inconsistencies
         | (name, inconsistencies) <-
           dependencyInconsistencies indepGoals graph ]
         --TODO: consider re-enabling this one, see SolverInstallPlan
    -}
    [PlanProblem ipkg srcpkg]
-> [PlanProblem ipkg srcpkg] -> [PlanProblem ipkg srcpkg]
forall a. [a] -> [a] -> [a]
++ [ GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> PlanProblem ipkg srcpkg
forall ipkg srcpkg.
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> PlanProblem ipkg srcpkg
PackageStateInvalid GenericPlanPackage ipkg srcpkg
pkg GenericPlanPackage ipkg srcpkg
pkg'
       | GenericPlanPackage ipkg srcpkg
pkg <- Graph (GenericPlanPackage ipkg srcpkg)
-> [GenericPlanPackage ipkg srcpkg]
forall a. Graph a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Graph (GenericPlanPackage ipkg srcpkg)
graph
       , Just GenericPlanPackage ipkg srcpkg
pkg' <-
          (UnitId -> Maybe (GenericPlanPackage ipkg srcpkg))
-> [UnitId] -> [Maybe (GenericPlanPackage ipkg srcpkg)]
forall a b. (a -> b) -> [a] -> [b]
map
            ((UnitId
 -> Graph (GenericPlanPackage ipkg srcpkg)
 -> Maybe (GenericPlanPackage ipkg srcpkg))
-> Graph (GenericPlanPackage ipkg srcpkg)
-> UnitId
-> Maybe (GenericPlanPackage ipkg srcpkg)
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId
-> Graph (GenericPlanPackage ipkg srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
Key (GenericPlanPackage ipkg srcpkg)
-> Graph (GenericPlanPackage ipkg srcpkg)
-> Maybe (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup Graph (GenericPlanPackage ipkg srcpkg)
graph)
            (GenericPlanPackage ipkg srcpkg
-> [Key (GenericPlanPackage ipkg srcpkg)]
forall a. IsNode a => a -> [Key a]
nodeNeighbors GenericPlanPackage ipkg srcpkg
pkg)
       , Bool -> Bool
not (GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
forall ipkg srcpkg.
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
stateDependencyRelation GenericPlanPackage ipkg srcpkg
pkg GenericPlanPackage ipkg srcpkg
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 @stateDependencyRelation a b = True@.
stateDependencyRelation
  :: GenericPlanPackage ipkg srcpkg
  -> GenericPlanPackage ipkg srcpkg
  -> Bool
stateDependencyRelation :: forall ipkg srcpkg.
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
stateDependencyRelation PreExisting{} PreExisting{} = Bool
True
stateDependencyRelation Installed{} PreExisting{} = Bool
True
stateDependencyRelation Installed{} Installed{} = Bool
True
stateDependencyRelation Configured{} PreExisting{} = Bool
True
stateDependencyRelation Configured{} Installed{} = Bool
True
stateDependencyRelation Configured{} Configured{} = Bool
True
stateDependencyRelation GenericPlanPackage ipkg srcpkg
_ GenericPlanPackage ipkg srcpkg
_ = Bool
False