content: {-# LANGUAGE BangPatterns #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  -----------------------------------------------------------------------------
  -- |
  -- 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,
    showInstallPlan,
  
    -- * Graph-like operations
    reverseTopologicalOrder,
    reverseDependencyClosure,
    ) where
  
  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.InstalledPackageInfo
           ( InstalledPackageInfo )
  import Distribution.Package
           ( Package(..), HasMungedPackageId(..)
           , HasUnitId(..), UnitId )
  import Distribution.Solver.Types.SolverPackage
  import Distribution.Client.JobControl
  import Distribution.Text
  import Text.PrettyPrint
  import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
  import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
  
  import qualified Distribution.Solver.Types.ComponentDeps as CD
  import           Distribution.Solver.Types.Settings
  import           Distribution.Solver.Types.SolverId
  import           Distribution.Solver.Types.InstSolverPackage
  
  import           Distribution.Utils.LogProgress
  
  -- TODO: Need this when we compute final UnitIds
  -- import qualified Distribution.Simple.Configure as Configure
  
  import Data.List
           ( foldl', intercalate )
  import qualified Data.Foldable as Foldable (all)
  import Data.Maybe
           ( fromMaybe, catMaybes )
  import qualified Distribution.Compat.Graph as Graph
  import Distribution.Compat.Graph (Graph, IsNode(..))
  import Distribution.Compat.Binary (Binary(..))
  import GHC.Generics
  import Data.Typeable
  import Control.Monad
  import Control.Exception
           ( assert )
  import qualified Data.Map as Map
  import           Data.Map (Map)
  import qualified Data.Set as Set
  import           Data.Set (Set)
  
  import Prelude hiding (lookup)
  
  
  -- 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 etlas 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 etlas). Instead, see 'PackageInstalled'.
  data GenericPlanPackage ipkg srcpkg
     = PreExisting ipkg
     | Configured  srcpkg
     | Installed   srcpkg
    deriving (Eq, Show, Generic)
  
  -- | 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 f _ (PreExisting ipkg)  = f ipkg
  foldPlanPackage _ g (Configured srcpkg) = g srcpkg
  foldPlanPackage _ g (Installed  srcpkg) = g srcpkg
  
  type IsUnit a = (IsNode a, Key a ~ UnitId)
  
  depends :: IsUnit a => a -> [UnitId]
  depends = 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 (PreExisting ipkg) = nodeKey ipkg
      nodeKey (Configured  spkg) = nodeKey spkg
      nodeKey (Installed   spkg) = nodeKey spkg
      nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
      nodeNeighbors (Configured  spkg) = nodeNeighbors spkg
      nodeNeighbors (Installed   spkg) = nodeNeighbors spkg
  
  instance (Binary ipkg, Binary srcpkg)
        => Binary (GenericPlanPackage ipkg srcpkg)
  
  type PlanPackage = GenericPlanPackage
                     InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)
  
  instance (Package ipkg, Package srcpkg) =>
           Package (GenericPlanPackage ipkg srcpkg) where
    packageId (PreExisting ipkg)     = packageId ipkg
    packageId (Configured  spkg)     = packageId spkg
    packageId (Installed   spkg)     = packageId spkg
  
  instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) =>
           HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where
    mungedId (PreExisting ipkg)     = mungedId ipkg
    mungedId (Configured  spkg)     = mungedId spkg
    mungedId (Installed   spkg)     = mungedId spkg
  
  instance (HasUnitId ipkg, HasUnitId srcpkg) =>
           HasUnitId
           (GenericPlanPackage ipkg srcpkg) where
    installedUnitId (PreExisting ipkg) = installedUnitId ipkg
    installedUnitId (Configured  spkg) = installedUnitId spkg
    installedUnitId (Installed   spkg) = installedUnitId spkg
  
  instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
            HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
      configuredId (PreExisting ipkg) = configuredId ipkg
      configuredId (Configured  spkg) = configuredId spkg
      configuredId (Installed   spkg) = configuredId spkg
  
  data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
      planGraph      :: !(Graph (GenericPlanPackage ipkg srcpkg)),
      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 loc graph indepGoals =
      assert (valid loc graph)
      GenericInstallPlan {
        planGraph      = graph,
        planIndepGoals = indepGoals
      }
  
  internalError :: String -> String -> a
  internalError loc msg = error $ "internal error in InstallPlan." ++ loc
                               ++ if null msg then "" else ": " ++ msg
  
  instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
            Binary ipkg, Binary srcpkg)
         => Binary (GenericInstallPlan ipkg srcpkg) where
      put GenericInstallPlan {
                planGraph      = graph,
                planIndepGoals = indepGoals
          } = put (graph, indepGoals)
  
      get = do
        (graph, indepGoals) <- get
        return $! mkInstallPlan "(instance Binary)" graph indepGoals
  
  showPlanGraph :: (Package ipkg, Package srcpkg,
                    IsUnit ipkg, IsUnit srcpkg)
                => Graph (GenericPlanPackage ipkg srcpkg) -> String
  showPlanGraph graph = renderStyle defaultStyle $
      vcat (map dispPlanPackage (Graph.toList graph))
    where dispPlanPackage p =
              hang (hsep [ text (showPlanPackageTag p)
                         , disp (packageId p)
                         , parens (disp (nodeKey p))]) 2
                   (vcat (map disp (nodeNeighbors p)))
  
  showInstallPlan :: (Package ipkg, Package srcpkg,
                      IsUnit ipkg, IsUnit srcpkg)
                  => GenericInstallPlan ipkg srcpkg -> String
  showInstallPlan = showPlanGraph . planGraph
  
  showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
  showPlanPackageTag (PreExisting _)   = "PreExisting"
  showPlanPackageTag (Configured  _)   = "Configured"
  showPlanPackageTag (Installed   _)   = "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 indepGoals graph = mkInstallPlan "new" graph indepGoals
  
  toGraph :: GenericInstallPlan ipkg srcpkg
          -> Graph (GenericPlanPackage ipkg srcpkg)
  toGraph = planGraph
  
  toList :: GenericInstallPlan ipkg srcpkg
         -> [GenericPlanPackage ipkg srcpkg]
  toList = Graph.toList . planGraph
  
  toMap :: GenericInstallPlan ipkg srcpkg
        -> Map UnitId (GenericPlanPackage ipkg srcpkg)
  toMap = Graph.toMap . planGraph
  
  keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
  keys = Graph.keys . planGraph
  
  keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
  keysSet = Graph.keysSet . 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 shouldRemove plan =
      mkInstallPlan "remove" newGraph (planIndepGoals plan)
    where
      newGraph = Graph.fromDistinctList $
                   filter (not . shouldRemove) (toList 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 shouldBeInstalled installPlan =
      foldl' markInstalled installPlan
        [ pkg
        | Configured pkg <- reverseTopologicalOrder installPlan
        , shouldBeInstalled pkg ]
    where
      markInstalled plan pkg =
        assert (all isInstalled (directDeps plan (nodeKey pkg))) $
        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 plan pkgid = Graph.lookup pkgid (planGraph 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 plan pkgid =
    case Graph.neighbors (planGraph plan) pkgid of
      Just deps -> deps
      Nothing   -> internalError "directDeps" "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 plan pkgid =
    case Graph.revNeighbors (planGraph plan) pkgid of
      Just deps -> deps
      Nothing   -> internalError "revDirectDeps" "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 plan = Graph.revTopSort (planGraph 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 plan = fromMaybe []
                                . Graph.revClosure (planGraph 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 f plan =
      mkInstallPlan "fromSolverInstallPlan"
        (Graph.fromDistinctList pkgs'')
        (SolverInstallPlan.planIndepGoals plan)
    where
      (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
                          (SolverInstallPlan.reverseTopologicalOrder plan)
  
      f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
        where
         pkgs' = f (mapDep pidMap ipiMap) pkg
  
         (pidMap', ipiMap')
           = case nodeKey pkg of
              PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
              PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)
  
      mapDep _ ipiMap (PreExistingId _pid uid)
          | Just pkgs <- Map.lookup uid ipiMap = pkgs
          | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)
      mapDep pidMap _ (PlannedId pid)
          | Just pkgs <- Map.lookup pid pidMap = pkgs
          | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display 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 f plan = do
      (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])
                          (SolverInstallPlan.reverseTopologicalOrder plan)
      return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
                 (Graph.fromDistinctList pkgs'')
                 (SolverInstallPlan.planIndepGoals plan)
    where
      f' (pidMap, ipiMap, pkgs) pkg = do
          pkgs' <- f (mapDep pidMap ipiMap) pkg
          let (pidMap', ipiMap')
                   = case nodeKey pkg of
                      PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
                      PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)
          return (pidMap', ipiMap', pkgs' ++ pkgs)
  
      mapDep _ ipiMap (PreExistingId _pid uid)
          | Just pkgs <- Map.lookup uid ipiMap = pkgs
          | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)
      mapDep pidMap _ (PlannedId pid)
          | Just pkgs <- Map.lookup pid pidMap = pkgs
          | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display 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 solverPlan =
      flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
        [case planpkg of
          SolverInstallPlan.PreExisting pkg ->
            PreExisting (instSolverPkgIPI pkg)
  
          SolverInstallPlan.Configured  pkg ->
            Configured (configureSolverPackage mapDep pkg)
        ]
    where
      configureSolverPackage :: (SolverId -> [PlanPackage])
                             -> SolverPackage UnresolvedPkgLoc
                             -> ConfiguredPackage UnresolvedPkgLoc
      configureSolverPackage mapDep spkg =
        ConfiguredPackage {
          confPkgId = Configure.computeComponentId
                          (Cabal.fromFlagOrDefault False
                              (Cabal.configDeterministic configFlags))
                          Cabal.NoFlag
                          Cabal.NoFlag
                          (packageId spkg)
                          PD.CLibName
                          (Just (map confInstId (CD.libraryDeps deps),
                                 solverPkgFlags spkg)),
          confPkgSource = solverPkgSource spkg,
          confPkgFlags  = solverPkgFlags spkg,
          confPkgStanzas = solverPkgStanzas spkg,
          confPkgDeps   = deps
          -- NB: no support for executable dependencies
        }
        where
          deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps 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 plan =
      assert (processingInvariant plan processing) $
      (readyPackages, processing)
    where
      !processing =
        Processing
          (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])
          (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])
          Set.empty
      readyPackages =
        [ ReadyPackage pkg
        | Configured pkg <- toList plan
        , all isInstalled (directDeps plan (nodeKey pkg))
        ]
  
  isInstalled :: GenericPlanPackage a b -> Bool
  isInstalled (PreExisting {}) = True
  isInstalled (Installed   {}) = True
  isInstalled _                = 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 :: (IsUnit ipkg, IsUnit srcpkg)
            => GenericInstallPlan ipkg srcpkg
            -> Processing -> UnitId
            -> ([GenericReadyPackage srcpkg], Processing)
  completed plan (Processing processingSet completedSet failedSet) pkgid =
      assert (pkgid `Set.member` processingSet) $
      assert (processingInvariant plan processing') $
  
      ( map asReadyPackage newlyReady
      , processing' )
    where
      completedSet'  = Set.insert pkgid completedSet
  
      -- each direct reverse dep where all direct deps are completed
      newlyReady     = [ dep
                       | dep <- revDirectDeps plan pkgid
                       , all ((`Set.member` completedSet') . nodeKey)
                             (directDeps plan (nodeKey dep))
                       ]
  
      processingSet' = foldl' (flip Set.insert)
                              (Set.delete pkgid processingSet)
                              (map nodeKey newlyReady)
      processing'    = Processing processingSet' completedSet' failedSet
  
      asReadyPackage (Configured pkg) = ReadyPackage pkg
      asReadyPackage _ = internalError "completed" ""
  
  failed :: (IsUnit ipkg, IsUnit srcpkg)
         => GenericInstallPlan ipkg srcpkg
         -> Processing -> UnitId
         -> ([srcpkg], Processing)
  failed plan (Processing processingSet completedSet failedSet) pkgid =
      assert (pkgid `Set.member` processingSet) $
      assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $
      assert (all (`Set.notMember` completedSet)  (tail newlyFailedIds)) $
      -- 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.
      assert (processingInvariant plan processing') $
  
      ( map asConfiguredPackage (tail newlyFailed)
      , processing' )
    where
      processingSet' = Set.delete pkgid processingSet
      failedSet'     = failedSet `Set.union` Set.fromList newlyFailedIds
      newlyFailedIds = map nodeKey newlyFailed
      newlyFailed    = fromMaybe (internalError "failed" "package not in graph")
                     $ Graph.revClosure (planGraph plan) [pkgid]
      processing'    = Processing processingSet' completedSet failedSet'
  
      asConfiguredPackage (Configured pkg) = pkg
      asConfiguredPackage _ = internalError "failed" "not in configured state"
  
  processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)
                      => GenericInstallPlan ipkg srcpkg
                      -> Processing -> Bool
  processingInvariant plan (Processing processingSet completedSet failedSet) =
  
      -- All the packages in the three sets are actually in the graph
      assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $
      assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $
      assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $
  
      -- The processing, completed and failed sets are disjoint from each other
      assert (noIntersection processingSet completedSet) $
      assert (noIntersection processingSet failedSet) $
      assert (noIntersection failedSet     completedSet) $
  
      -- Packages that depend on a package that's still processing cannot be
      -- completed
      assert (noIntersection (reverseClosure processingSet) completedSet) $
  
      -- 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
      assert (failedSet == reverseClosure failedSet) $
  
      -- All immediate reverse deps of packges that are currently processing
      -- are not currently being processed (ie not in the processing set).
      assert (and [ rdeppkgid `Set.notMember` processingSet
                  | pkgid     <- Set.toList processingSet
                  , rdeppkgid <- maybe (internalError "processingInvariant" "")
                                       (map nodeKey)
                                       (Graph.revNeighbors (planGraph plan) pkgid)
                  ]) $
  
      -- Packages from the processing or failed sets are only ever in the
      -- configured state.
      assert (and [ case Graph.lookup pkgid (planGraph plan) of
                      Just (Configured  _) -> True
                      Just (PreExisting _) -> False
                      Just (Installed   _) -> False
                      Nothing              -> False
                  | pkgid <- Set.toList processingSet ++ Set.toList failedSet ])
  
      -- We use asserts rather than returning False so that on failure we get
      -- better details on which bit of the invariant was violated.
      True
    where
      reverseClosure    = Set.fromList
                        . map nodeKey
                        . fromMaybe (internalError "processingInvariant" "")
                        . Graph.revClosure (planGraph plan)
                        . Set.toList
      noIntersection a b = Set.null (Set.intersection a b)
  
  
  -- ------------------------------------------------------------
  -- * Traversing plans
  -- ------------------------------------------------------------
  
  -- | Flatten an 'InstallPlan', producing the sequence of source packages in
  -- the order in which they would be processed when the plan is executed. This
  -- can be used for simultations or presenting execution dry-runs.
  --
  -- It is guaranteed to give the same order as using 'execute' (with a serial
  -- in-order 'JobControl'), which is a reverse topological orderings of the
  -- source packages in the dependency graph, albeit not necessarily exactly the
  -- same ordering as that produced by 'reverseTopologicalOrder'.
  --
  executionOrder :: (IsUnit ipkg, IsUnit srcpkg)
                 => GenericInstallPlan ipkg srcpkg
                 -> [GenericReadyPackage srcpkg]
  executionOrder plan =
      let (newpkgs, processing) = ready plan
       in tryNewTasks processing newpkgs
    where
      tryNewTasks _processing []       = []
      tryNewTasks  processing (p:todo) = waitForTasks processing p todo
  
      waitForTasks processing p todo =
          p : tryNewTasks processing' (todo++nextpkgs)
        where
          (nextpkgs, processing') = completed plan processing (nodeKey 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 = Map.lookup . installedUnitId
  
  -- | Execute an install plan. This traverses the plan in dependency order.
  --
  -- Executing each individual package can fail and if so all dependents fail
  -- too. The result for each package is collected as a '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 jobCtl keepGoing depFailure plan installPkg =
      let (newpkgs, processing) = ready plan
       in tryNewTasks Map.empty False False processing newpkgs
    where
      tryNewTasks :: BuildOutcomes failure result
                  -> Bool -> Bool -> Processing
                  -> [GenericReadyPackage srcpkg]
                  -> m (BuildOutcomes failure result)
  
      tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs
        -- we were in the process of cancelling and now we're finished
        | tasksFailed && not keepGoing && not tasksRemaining
        = return results
  
        -- we are still in the process of cancelling, wait for remaining tasks
        | tasksFailed && not keepGoing && tasksRemaining
        = waitForTasks results tasksFailed processing
  
        -- no new tasks to do and all tasks are done so we're finished
        | null newpkgs && not tasksRemaining
        = return results
  
        -- no new tasks to do, remaining tasks to wait for
        | null newpkgs
        = waitForTasks results tasksFailed processing
  
        -- new tasks to do, spawn them, then wait for tasks to complete
        | otherwise
        = do sequence_ [ spawnJob jobCtl $ do
                           result <- installPkg pkg
                           return (nodeKey pkg, result)
                       | pkg <- newpkgs ]
             waitForTasks results tasksFailed processing
  
      waitForTasks :: BuildOutcomes failure result
                   -> Bool -> Processing
                   -> m (BuildOutcomes failure result)
      waitForTasks !results tasksFailed !processing = do
        (pkgid, result) <- collectJob jobCtl
  
        case result of
  
          Right _success -> do
              tasksRemaining <- remainingJobs jobCtl
              tryNewTasks results' tasksFailed tasksRemaining
                          processing' nextpkgs
            where
              results' = Map.insert pkgid result results
              (nextpkgs, processing') = completed plan processing pkgid
  
          Left _failure -> do
              -- if this is the first failure and we're not trying to keep going
              -- then try to cancel as many of the remaining jobs as possible
              when (not tasksFailed && not keepGoing) $
                cancelJobs jobCtl
  
              tasksRemaining <- remainingJobs jobCtl
              tryNewTasks results' True tasksRemaining processing' []
            where
              (depsfailed, processing') = failed plan processing pkgid
              results'   = Map.insert pkgid result results `Map.union` depResults
              depResults = Map.fromList
                             [ (nodeKey deppkg, Left (depFailure deppkg))
                             | deppkg <- 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 loc graph =
      case problems graph of
        [] -> True
        ps -> internalError loc ('\n' : unlines (map showPlanProblem 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 (PackageMissingDeps pkg missingDeps) =
       "Package " ++ display (nodeKey pkg)
    ++ " depends on the following packages which are missing from the plan: "
    ++ intercalate ", " (map display missingDeps)
  
  showPlanProblem (PackageCycle cycleGroup) =
       "The following packages are involved in a dependency cycle "
    ++ intercalate ", " (map (display . nodeKey) cycleGroup)
  showPlanProblem (PackageStateInvalid pkg pkg') =
       "Package " ++ display (nodeKey pkg)
    ++ " is in the " ++ showPlanPackageTag pkg
    ++ " state but it depends on package " ++ display (nodeKey pkg')
    ++ " which is in the " ++ showPlanPackageTag pkg'
    ++ " 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 graph =
  
       [ PackageMissingDeps pkg
         (catMaybes
          (map
           (fmap nodeKey . flip Graph.lookup graph)
           missingDeps))
       | (pkg, missingDeps) <- Graph.broken graph ]
  
    ++ [ PackageCycle cycleGroup
       | cycleGroup <- Graph.cycles graph ]
  {-
    ++ [ PackageInconsistency name inconsistencies
       | (name, inconsistencies) <-
         dependencyInconsistencies indepGoals graph ]
       --TODO: consider re-enabling this one, see SolverInstallPlan
  -}
    ++ [ PackageStateInvalid pkg pkg'
       | pkg <- Graph.toList graph
       , Just pkg' <- map (flip Graph.lookup graph)
                      (nodeNeighbors pkg)
       , not (stateDependencyRelation pkg pkg') ]
  
  -- | The states of packages have that depend on each other must respect
  -- this relation. That is for very case where package @a@ depends on
  -- package @b@ we require that @stateDependencyRelation a b = True@.
  --
  stateDependencyRelation :: GenericPlanPackage ipkg srcpkg
                          -> GenericPlanPackage ipkg srcpkg -> Bool
  stateDependencyRelation PreExisting{} PreExisting{} = True
  
  stateDependencyRelation Installed{}   PreExisting{} = True
  stateDependencyRelation Installed{}   Installed{}   = True
  
  stateDependencyRelation Configured{}  PreExisting{} = True
  stateDependencyRelation Configured{}  Installed{}   = True
  stateDependencyRelation Configured{}  Configured{}  = True
  
  stateDependencyRelation _             _             = False
  