{-# 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
  dependencyClosure,
  reverseTopologicalOrder,
  reverseDependencyClosure,
  ) where

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

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.Pretty (defaultStyle)
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
import           Distribution.Utils.Structured (Structured (..), Structure(Nominal))

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

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

-- 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall ipkg srcpkg.
(Eq ipkg, Eq srcpkg) =>
GenericPlanPackage ipkg srcpkg
-> GenericPlanPackage ipkg srcpkg -> Bool
Eq, Int -> GenericPlanPackage ipkg srcpkg -> ShowS
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
showList :: [GenericPlanPackage ipkg srcpkg] -> ShowS
$cshowList :: forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
[GenericPlanPackage ipkg srcpkg] -> ShowS
show :: GenericPlanPackage ipkg srcpkg -> String
$cshow :: forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
GenericPlanPackage ipkg srcpkg -> String
showsPrec :: Int -> GenericPlanPackage ipkg srcpkg -> ShowS
$cshowsPrec :: forall ipkg srcpkg.
(Show ipkg, Show srcpkg) =>
Int -> GenericPlanPackage ipkg srcpkg -> ShowS
Show, 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
$cto :: forall ipkg srcpkg x.
Rep (GenericPlanPackage ipkg srcpkg) x
-> GenericPlanPackage ipkg srcpkg
$cfrom :: forall ipkg srcpkg x.
GenericPlanPackage ipkg srcpkg
-> Rep (GenericPlanPackage ipkg srcpkg) x
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 " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall a. IsNode a => a -> Key a
nodeKey ipkg
pkg)
displayGenericPlanPackage (Configured srcpkg
pkg)  = String
"Configured " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall a. IsNode a => a -> Key a
nodeKey srcpkg
pkg)
displayGenericPlanPackage (Installed srcpkg
pkg)   = String
"Installed " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (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 = 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) = forall a. IsNode a => a -> Key a
nodeKey ipkg
ipkg
    nodeKey (Configured  srcpkg
spkg) = forall a. IsNode a => a -> Key a
nodeKey srcpkg
spkg
    nodeKey (Installed   srcpkg
spkg) = forall a. IsNode a => a -> Key a
nodeKey srcpkg
spkg
    nodeNeighbors :: GenericPlanPackage ipkg srcpkg
-> [Key (GenericPlanPackage ipkg srcpkg)]
nodeNeighbors (PreExisting ipkg
ipkg) = forall a. IsNode a => a -> [Key a]
nodeNeighbors ipkg
ipkg
    nodeNeighbors (Configured  srcpkg
spkg) = forall a. IsNode a => a -> [Key a]
nodeNeighbors srcpkg
spkg
    nodeNeighbors (Installed   srcpkg
spkg) = 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)     = forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ipkg
ipkg
  packageId (Configured  srcpkg
spkg)     = forall pkg. Package pkg => pkg -> PackageIdentifier
packageId srcpkg
spkg
  packageId (Installed   srcpkg
spkg)     = 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)     = forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId ipkg
ipkg
  mungedId (Configured  srcpkg
spkg)     = forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId srcpkg
spkg
  mungedId (Installed   srcpkg
spkg)     = 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) = forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ipkg
ipkg
  installedUnitId (Configured  srcpkg
spkg) = forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId srcpkg
spkg
  installedUnitId (Installed   srcpkg
spkg) = 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) = forall a. HasConfiguredId a => a -> ConfiguredId
configuredId ipkg
ipkg
    configuredId (Configured  srcpkg
spkg) = forall a. HasConfiguredId a => a -> ConfiguredId
configuredId srcpkg
spkg
    configuredId (Installed   srcpkg
spkg) = 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 =
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (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 = forall a. (?callStack::CallStack) => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"internal error in InstallPlan." forall a. [a] -> [a] -> [a]
++ String
loc
                             forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
msg then String
"" else String
": " 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 (forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (GenericInstallPlan ipkg srcpkg)
p) TypeVersion
0 String
"GenericInstallPlan"
        [ forall a. Structured a => Proxy a -> Structure
structure (forall {k} (t :: k). Proxy t
Proxy :: Proxy ipkg)
        , forall a. Structured a => Proxy a -> Structure
structure (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
        } = forall t. Binary t => t -> Put
put Graph (GenericPlanPackage ipkg srcpkg)
graph forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall t. Binary t => t -> Put
put IndependentGoals
indepGoals

    get :: Get (GenericInstallPlan ipkg srcpkg)
get = do
      Graph (GenericPlanPackage ipkg srcpkg)
graph <- forall t. Binary t => Get t
get
      IndependentGoals
indepGoals <- forall t. Binary t => Get t
get
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! 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

showPlanGraph :: (Package ipkg, Package srcpkg,
                  IsUnit ipkg, IsUnit srcpkg)
              => Graph (GenericPlanPackage ipkg srcpkg) -> String
showPlanGraph :: forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
Graph (GenericPlanPackage ipkg srcpkg) -> String
showPlanGraph Graph (GenericPlanPackage ipkg srcpkg)
graph = Style -> Doc -> String
renderStyle Style
defaultStyle forall a b. (a -> b) -> a -> b
$
    [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall {ipkg} {srcpkg}.
(Key ipkg ~ UnitId, Key srcpkg ~ UnitId, Package ipkg,
 Package srcpkg, IsNode ipkg, IsNode srcpkg) =>
GenericPlanPackage ipkg srcpkg -> Doc
dispPlanPackage (forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Graph (GenericPlanPackage ipkg srcpkg)
graph))
  where dispPlanPackage :: GenericPlanPackage ipkg srcpkg -> Doc
dispPlanPackage GenericPlanPackage ipkg srcpkg
p =
            Doc -> Int -> Doc -> Doc
hang ([Doc] -> Doc
hsep [ String -> Doc
text (forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag GenericPlanPackage ipkg srcpkg
p)
                       , forall a. Pretty a => a -> Doc
pretty (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId GenericPlanPackage ipkg srcpkg
p)
                       , Doc -> Doc
parens (forall a. Pretty a => a -> Doc
pretty (forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
p))]) Int
2
                 ([Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> Doc
pretty (forall a. IsNode a => a -> [Key a]
nodeNeighbors GenericPlanPackage ipkg srcpkg
p)))

showInstallPlan :: (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 = forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
Graph (GenericPlanPackage ipkg srcpkg) -> String
showPlanGraph forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph

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 = 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 = 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 = forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Graph a -> Map (Key a) a
Graph.toMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Graph a -> [Key a]
Graph.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. Graph a -> Set (Key a)
Graph.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
"remove" Graph (GenericPlanPackage ipkg srcpkg)
newGraph (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> IndependentGoals
planIndepGoals GenericInstallPlan ipkg srcpkg
plan)
  where
    newGraph :: Graph (GenericPlanPackage ipkg srcpkg)
newGraph = forall a. (IsNode a, Show (Key a)) => [a] -> Graph a
Graph.fromDistinctList forall a b. (a -> b) -> a -> b
$
                 forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPlanPackage ipkg srcpkg -> Bool
shouldRemove) (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 =
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {srcpkg} {ipkg}.
(Key srcpkg ~ UnitId, Key ipkg ~ UnitId, IsNode srcpkg,
 IsNode ipkg) =>
GenericInstallPlan ipkg srcpkg
-> srcpkg -> GenericInstallPlan ipkg srcpkg
markInstalled GenericInstallPlan ipkg srcpkg
installPlan
      [ srcpkg
pkg
      | Configured srcpkg
pkg <- 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 =
      forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. GenericPlanPackage a b -> Bool
isInstalled (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan (forall a. IsNode a => a -> Key a
nodeKey srcpkg
pkg))) forall a b. (a -> b) -> a -> b
$
      GenericInstallPlan ipkg srcpkg
plan {
        planGraph :: Graph (GenericPlanPackage ipkg srcpkg)
planGraph = forall a. IsNode a => a -> Graph a -> Graph a
Graph.insert (forall ipkg srcpkg. srcpkg -> GenericPlanPackage ipkg srcpkg
Installed srcpkg
pkg) (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
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 = forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup UnitId
pkgid (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 forall a. Graph a -> Key a -> Maybe [a]
Graph.neighbors (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) UnitId
pkgid of
    Just [GenericPlanPackage ipkg srcpkg]
deps -> [GenericPlanPackage ipkg srcpkg]
deps
    Maybe [GenericPlanPackage ipkg srcpkg]
Nothing   -> 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 forall a. Graph a -> Key a -> Maybe [a]
Graph.revNeighbors (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) UnitId
pkgid of
    Just [GenericPlanPackage ipkg srcpkg]
deps -> [GenericPlanPackage ipkg srcpkg]
deps
    Maybe [GenericPlanPackage ipkg srcpkg]
Nothing   -> 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 = forall a. Graph a -> [a]
Graph.revTopSort (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 = forall a. a -> Maybe a -> a
fromMaybe []
                       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Graph a -> [Key a] -> Maybe [a]
Graph.closure (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 = forall a. a -> Maybe a -> a
fromMaybe []
                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure (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 =
    forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
"fromSolverInstallPlan"
      (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'') = 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' (forall k a. Map k a
Map.empty, 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' forall a. [a] -> [a] -> [a]
++ [GenericPlanPackage ipkg srcpkg]
pkgs)
      where
       pkgs' :: [GenericPlanPackage ipkg srcpkg]
pkgs' = (SolverId -> [GenericPlanPackage ipkg srcpkg])
-> SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg]
f (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 forall a. IsNode a => a -> Key a
nodeKey SolverPlanPackage
pkg of
            PreExistingId PackageIdentifier
_ UnitId
uid -> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, 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   -> (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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId a
ipiMap = a
pkgs
        | Bool
otherwise = forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PreExistingId " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow UnitId
uid)
    mapDep Map PackageIdentifier a
pidMap Map UnitId a
_ (PlannedId PackageIdentifier
pid)
        | Just a
pkgs <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pid Map PackageIdentifier a
pidMap = a
pkgs
        | Bool
otherwise = forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PlannedId " forall a. [a] -> [a] -> [a]
++ 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'') <- 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' (forall k a. Map k a
Map.empty, forall k a. Map k a
Map.empty, [])
                        (SolverInstallPlan -> [SolverPlanPackage]
SolverInstallPlan.reverseTopologicalOrder SolverInstallPlan
plan)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
String
-> Graph (GenericPlanPackage ipkg srcpkg)
-> IndependentGoals
-> GenericInstallPlan ipkg srcpkg
mkInstallPlan String
"fromSolverInstallPlanWithProgress"
               (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 (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 forall a. IsNode a => a -> Key a
nodeKey SolverPlanPackage
pkg of
                    PreExistingId PackageIdentifier
_ UnitId
uid -> (Map PackageIdentifier [GenericPlanPackage ipkg srcpkg]
pidMap, 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   -> (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)
        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' 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 <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId a
ipiMap = a
pkgs
        | Bool
otherwise = forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PreExistingId " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow UnitId
uid)
    mapDep Map PackageIdentifier a
pidMap Map UnitId a
_ (PlannedId PackageIdentifier
pid)
        | Just a
pkgs <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pid Map PackageIdentifier a
pidMap = a
pkgs
        | Bool
otherwise = forall a. (?callStack::CallStack) => String -> a
error (String
"fromSolverInstallPlan: PlannedId " forall a. [a] -> [a] -> [a]
++ 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 =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
((SolverId -> [GenericPlanPackage ipkg srcpkg])
 -> SolverPlanPackage -> [GenericPlanPackage ipkg srcpkg])
-> SolverInstallPlan -> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan SolverInstallPlan
solverPlan forall a b. (a -> b) -> a -> b
$ \SolverId -> [PlanPackage]
mapDep SolverPlanPackage
planpkg ->
      [case SolverPlanPackage
planpkg of
        SolverInstallPlan.PreExisting InstSolverPackage
pkg ->
          forall ipkg srcpkg. ipkg -> GenericPlanPackage ipkg srcpkg
PreExisting (InstSolverPackage -> InstalledPackageInfo
instSolverPkgIPI InstSolverPackage
pkg)

        SolverInstallPlan.Configured  SolverPackage UnresolvedPkgLoc
pkg ->
          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
                        (forall a. a -> Flag a -> a
Cabal.fromFlagOrDefault Bool
False
                            (ConfigFlags -> Flag Bool
Cabal.configDeterministic ConfigFlags
configFlags))
                        forall a. Flag a
Cabal.NoFlag
                        forall a. Flag a
Cabal.NoFlag
                        (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId SolverPackage UnresolvedPkgLoc
spkg)
                        (LibraryName -> ComponentName
PD.CLibName LibraryName
PD.LMainLibName)
                        (forall a. a -> Maybe a
Just (forall a b. (a -> b) -> [a] -> [b]
map ConfiguredId -> InstalledPackageId
confInstId (forall a. Monoid a => ComponentDeps a -> a
CD.libraryDeps ComponentDeps [ConfiguredId]
deps),
                               forall loc. SolverPackage loc -> FlagAssignment
solverPkgFlags SolverPackage UnresolvedPkgLoc
spkg)),
        confPkgSource :: SourcePackage UnresolvedPkgLoc
confPkgSource = forall loc. SolverPackage loc -> SourcePackage loc
solverPkgSource SolverPackage UnresolvedPkgLoc
spkg,
        confPkgFlags :: FlagAssignment
confPkgFlags  = forall loc. SolverPackage loc -> FlagAssignment
solverPkgFlags SolverPackage UnresolvedPkgLoc
spkg,
        confPkgStanzas :: OptionalStanzaSet
confPkgStanzas = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> b) -> [a] -> [b]
map forall a. HasConfiguredId a => a -> ConfiguredId
configuredId forall b c a. (b -> c) -> (a -> b) -> a -> c
. SolverId -> [PlanPackage]
mapDep)) (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 =
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan Processing
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
        (forall a. Ord a => [a] -> Set a
Set.fromList [ forall a. IsNode a => a -> Key a
nodeKey GenericReadyPackage srcpkg
pkg | GenericReadyPackage srcpkg
pkg <- [GenericReadyPackage srcpkg]
readyPackages ])
        (forall a. Ord a => [a] -> Set a
Set.fromList [ forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg | GenericPlanPackage ipkg srcpkg
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
toList GenericInstallPlan ipkg srcpkg
plan, forall a b. GenericPlanPackage a b -> Bool
isInstalled GenericPlanPackage ipkg srcpkg
pkg ])
        forall a. Set a
Set.empty
    readyPackages :: [GenericReadyPackage srcpkg]
readyPackages =
      [ forall srcpkg. srcpkg -> GenericReadyPackage srcpkg
ReadyPackage srcpkg
pkg
      | Configured srcpkg
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
toList GenericInstallPlan ipkg srcpkg
plan
      , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a b. GenericPlanPackage a b -> Bool
isInstalled (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan (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 =
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (UnitId
pkgid forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
processingSet) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan Processing
processing') forall a b. (a -> b) -> a -> b
$

    ( 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'  = 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 <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
revDirectDeps GenericInstallPlan ipkg srcpkg
plan UnitId
pkgid
                     , forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
completedSet') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsNode a => a -> Key a
nodeKey)
                           (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
directDeps GenericInstallPlan ipkg srcpkg
plan (forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
dep))
                     ]

    processingSet' :: Set UnitId
processingSet' = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> Set a -> Set a
Set.insert)
                            (forall a. Ord a => a -> Set a -> Set a
Set.delete UnitId
pkgid Set UnitId
processingSet)
                            (forall a b. (a -> b) -> [a] -> [b]
map 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)  = forall srcpkg. srcpkg -> GenericReadyPackage srcpkg
ReadyPackage srcpkg
pkg
    asReadyPackage GenericPlanPackage ipkg srcpkg
pkg = forall a. WithCallStack (String -> String -> a)
internalError String
"completed" forall a b. (a -> b) -> a -> b
$ String
"not in configured state: " forall a. [a] -> [a] -> [a]
++ 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 =
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (UnitId
pkgid forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
processingSet) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
processingSet) (forall a. [a] -> [a]
tail [UnitId]
newlyFailedIds)) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
completedSet)  (forall a. [a] -> [a]
tail [UnitId]
newlyFailedIds)) 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.
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> Processing -> Bool
processingInvariant GenericInstallPlan ipkg srcpkg
plan Processing
processing') forall a b. (a -> b) -> a -> b
$

    ( forall a b. (a -> b) -> [a] -> [b]
map forall {ipkg} {srcpkg}.
(Key ipkg ~ UnitId, Key srcpkg ~ UnitId, IsNode ipkg,
 IsNode srcpkg) =>
GenericPlanPackage ipkg srcpkg -> srcpkg
asConfiguredPackage (forall a. [a] -> [a]
tail [GenericPlanPackage ipkg srcpkg]
newlyFailed)
    , Processing
processing' )
  where
    processingSet' :: Set UnitId
processingSet' = forall a. Ord a => a -> Set a -> Set a
Set.delete UnitId
pkgid Set UnitId
processingSet
    failedSet' :: Set UnitId
failedSet'     = Set UnitId
failedSet forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall a. Ord a => [a] -> Set a
Set.fromList [UnitId]
newlyFailedIds
    newlyFailedIds :: [UnitId]
newlyFailedIds = forall a b. (a -> b) -> [a] -> [b]
map forall a. IsNode a => a -> Key a
nodeKey [GenericPlanPackage ipkg srcpkg]
newlyFailed
    newlyFailed :: [GenericPlanPackage ipkg srcpkg]
newlyFailed    = forall a. a -> Maybe a -> a
fromMaybe (forall a. WithCallStack (String -> String -> a)
internalError String
"failed" String
"package not in graph")
                   forall a b. (a -> b) -> a -> b
$ forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) [UnitId
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 = forall a. WithCallStack (String -> String -> a)
internalError String
"failed" forall a b. (a -> b) -> a -> b
$ String
"not in configured state: " forall a. [a] -> [a] -> [a]
++ 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
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.all (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IsNode a => Key a -> Graph a -> Bool
Graph.member (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)) Set UnitId
processingSet) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.all (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IsNode a => Key a -> Graph a -> Bool
Graph.member (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)) Set UnitId
completedSet) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Foldable.all (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IsNode a => Key a -> Graph a -> Bool
Graph.member (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)) Set UnitId
failedSet) forall a b. (a -> b) -> a -> b
$

    -- The processing, completed and failed sets are disjoint from each other
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection Set UnitId
processingSet Set UnitId
completedSet) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection Set UnitId
processingSet Set UnitId
failedSet) forall a b. (a -> b) -> a -> b
$
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection Set UnitId
failedSet     Set UnitId
completedSet) forall a b. (a -> b) -> a -> b
$

    -- Packages that depend on a package that's still processing cannot be
    -- completed
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall {a}. Ord a => Set a -> Set a -> Bool
noIntersection (Set UnitId -> Set UnitId
reverseClosure Set UnitId
processingSet) Set UnitId
completedSet) 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
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set UnitId
failedSet forall a. Eq a => a -> a -> Bool
== Set UnitId -> Set UnitId
reverseClosure Set UnitId
failedSet) 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).
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ UnitId
rdeppkgid forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
processingSet
                | UnitId
pkgid     <- forall a. Set a -> [a]
Set.toList Set UnitId
processingSet
                , UnitId
rdeppkgid <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. WithCallStack (String -> String -> a)
internalError String
"processingInvariant" String
"")
                                     (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsNode a => a -> Key a
nodeKey)
                                     (forall a. Graph a -> Key a -> Maybe [a]
Graph.revNeighbors (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan) UnitId
pkgid)
                ]) forall a b. (a -> b) -> a -> b
$

    -- Packages from the processing or failed sets are only ever in the
    -- configured state.
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ case forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup UnitId
pkgid (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 <- forall a. Set a -> [a]
Set.toList Set UnitId
processingSet forall a. [a] -> [a] -> [a]
++ 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    = forall a. Ord a => [a] -> Set a
Set.fromList
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. IsNode a => a -> Key a
nodeKey
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (forall a. WithCallStack (String -> String -> a)
internalError String
"processingInvariant" String
"")
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Graph a -> [Key a] -> Maybe [a]
Graph.revClosure (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Graph (GenericPlanPackage ipkg srcpkg)
planGraph GenericInstallPlan ipkg srcpkg
plan)
                      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
Set.toList
    noIntersection :: Set a -> Set a -> Bool
noIntersection Set a
a Set a
b = forall a. Set a -> Bool
Set.null (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) = 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 forall a. a -> [a] -> [a]
: Processing
-> [GenericReadyPackage srcpkg] -> [GenericReadyPackage srcpkg]
tryNewTasks Processing
processing' ([GenericReadyPackage srcpkg]
todoforall a. [a] -> [a] -> [a]
++[GenericReadyPackage srcpkg]
nextpkgs)
      where
        ([GenericReadyPackage srcpkg]
nextpkgs, Processing
processing') = forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> Processing
-> UnitId
-> ([GenericReadyPackage srcpkg], Processing)
completed GenericInstallPlan ipkg srcpkg
plan Processing
processing (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 = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = 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 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
      = 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
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage srcpkg]
newpkgs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tasksRemaining
      = forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcomes failure result
results

      -- no new tasks to do, remaining tasks to wait for
      | 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 forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ forall (m :: * -> *) a. JobControl m a -> m a -> m ()
spawnJob JobControl m (UnitId, Either failure result)
jobCtl forall a b. (a -> b) -> a -> b
$ do
                         Either failure result
result <- GenericReadyPackage srcpkg -> m (Either failure result)
installPkg GenericReadyPackage srcpkg
pkg
                         forall (m :: * -> *) a. Monad m => a -> m a
return (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) <- 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 <- 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' = 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') = 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
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
tasksFailed Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
keepGoing) forall a b. (a -> b) -> a -> b
$
              forall (m :: * -> *) a. JobControl m a -> m ()
cancelJobs JobControl m (UnitId, Either failure result)
jobCtl

            Bool
tasksRemaining <- 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') = 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'   = 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 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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                           [ (forall a. IsNode a => a -> Key a
nodeKey srcpkg
deppkg, 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 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 -> forall a. WithCallStack (String -> String -> a)
internalError String
loc (Char
'\n' forall a. a -> [a] -> [a]
: [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map 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 " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg)
  forall a. [a] -> [a] -> [a]
++ String
" depends on the following packages which are missing from the plan: "
  forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map 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 "
  forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsNode a => a -> Key a
nodeKey) [GenericPlanPackage ipkg srcpkg]
cycleGroup)
showPlanProblem (PackageStateInvalid GenericPlanPackage ipkg srcpkg
pkg GenericPlanPackage ipkg srcpkg
pkg') =
     String
"Package " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg)
  forall a. [a] -> [a] -> [a]
++ String
" is in the " forall a. [a] -> [a] -> [a]
++ forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag GenericPlanPackage ipkg srcpkg
pkg
  forall a. [a] -> [a] -> [a]
++ String
" state but it depends on package " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg')
  forall a. [a] -> [a] -> [a]
++ String
" which is in the " forall a. [a] -> [a] -> [a]
++ forall ipkg srcpkg. GenericPlanPackage ipkg srcpkg -> String
showPlanPackageTag GenericPlanPackage ipkg srcpkg
pkg'
  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 =

     [ forall ipkg srcpkg.
GenericPlanPackage ipkg srcpkg
-> [UnitId] -> PlanProblem ipkg srcpkg
PackageMissingDeps GenericPlanPackage ipkg srcpkg
pkg
       (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
         (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. IsNode a => a -> Key a
nodeKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip 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) <- forall a. Graph a -> [(a, [Key a])]
Graph.broken Graph (GenericPlanPackage ipkg srcpkg)
graph ]

  forall a. [a] -> [a] -> [a]
++ [ forall ipkg srcpkg.
[GenericPlanPackage ipkg srcpkg] -> PlanProblem ipkg srcpkg
PackageCycle [GenericPlanPackage ipkg srcpkg]
cycleGroup
     | [GenericPlanPackage ipkg srcpkg]
cycleGroup <- 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
-}
  forall a. [a] -> [a] -> [a]
++ [ 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 <- forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList Graph (GenericPlanPackage ipkg srcpkg)
graph
     , Just GenericPlanPackage ipkg srcpkg
pkg' <- forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. IsNode a => Key a -> Graph a -> Maybe a
Graph.lookup Graph (GenericPlanPackage ipkg srcpkg)
graph)
                    (forall a. IsNode a => a -> [Key a]
nodeNeighbors GenericPlanPackage ipkg srcpkg
pkg)
     , Bool -> Bool
not (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