InstallPlan.hs

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Packages in an install plan
--
-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
-- intentionally have no 'PackageInstalled' instance. `This is important:
-- PackageInstalled returns only library dependencies, but for package that
-- aren't yet installed we know many more kinds of dependencies (setup
-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
-- dependencies in cabal-install should consider what to do with these
-- dependencies; if we give a 'PackageInstalled' instance it would be too easy
-- to get this wrong (and, for instance, call graph traversal functions from
-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.
data GenericPlanPackage ipkg srcpkg
  = PreExisting ipkg
  | Configured srcpkg
  | Installed srcpkg
  deriving (Eq, Show, Generic)

displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String
displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)
displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)
displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey 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 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)
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 (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
  }

-- | '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 :: WithCallStack (String -> String -> a)
internalError loc msg =
  error $
    "internal error in InstallPlan."
      ++ loc
      ++ if null msg then "" else ": " ++ msg

instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where
  structure p =
    Nominal
      (typeRep p)
      0
      "GenericInstallPlan"
      [ structure (Proxy :: Proxy ipkg)
      , structure (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
      { planGraph = graph
      , planIndepGoals = indepGoals
      } = put graph >> put indepGoals

  get = do
    graph <- get
    indepGoals <- get
    return $! mkInstallPlan "(instance Binary)" graph indepGoals

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

showPlanGraph :: [ShowPlanNode] -> String
showPlanGraph graph =
  renderStyle defaultStyle $
    vcat (map dispPlanPackage graph)
  where
    dispPlanPackage (ShowPlanNode herald neighbours) =
      hang herald 2 (vcat neighbours)

-- | Generic way to show a 'GenericInstallPlan' which elicits quite a lot of information
showInstallPlan_gen
  :: forall ipkg srcpkg
   . (GenericPlanPackage ipkg srcpkg -> ShowPlanNode)
  -> GenericInstallPlan ipkg srcpkg
  -> String
showInstallPlan_gen toShow = showPlanGraph . fmap toShow . Foldable.toList . planGraph

showInstallPlan
  :: forall ipkg srcpkg
   . (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg)
  => GenericInstallPlan ipkg srcpkg
  -> String
showInstallPlan = showInstallPlan_gen toShow
  where
    toShow :: GenericPlanPackage ipkg srcpkg -> ShowPlanNode
    toShow p =
      ShowPlanNode
        ( hsep
            [ text (showPlanPackageTag p)
            , pretty (packageId p)
            , parens (pretty (nodeKey p))
            ]
        )
        (map pretty (nodeNeighbors p))

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 = Foldable.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 are direct or indirect dependencies of
-- the given packages.
dependencyClosure
  :: GenericInstallPlan ipkg srcpkg
  -> [UnitId]
  -> [GenericPlanPackage ipkg srcpkg]
dependencyClosure plan =
  fromMaybe []
    . Graph.closure (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 " ++ prettyShow uid)
    mapDep pidMap _ (PlannedId pid)
      | Just pkgs <- Map.lookup pid pidMap = pkgs
      | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow 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 " ++ prettyShow uid)
    mapDep pidMap _ (PlannedId pid)
      | Just pkgs <- Map.lookup pid pidMap = pkgs
      | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow 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 PD.LMainLibName)
              ( 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
  :: forall ipkg srcpkg
   . (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 :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg
    asReadyPackage (Configured pkg) = ReadyPackage pkg
    asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg

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) (drop 1 newlyFailedIds)) $
      assert (all (`Set.notMember` completedSet) (drop 1 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 (drop 1 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 pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg

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 packages 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 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 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 "
    ++ prettyShow (nodeKey pkg)
    ++ " depends on the following packages which are missing from the plan: "
    ++ intercalate ", " (map prettyShow missingDeps)
showPlanProblem (PackageCycle cycleGroup) =
  "The following packages are involved in a dependency cycle "
    ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)
showPlanProblem (PackageStateInvalid pkg pkg') =
  "Package "
    ++ prettyShow (nodeKey pkg)
    ++ " is in the "
    ++ showPlanPackageTag pkg
    ++ " state but it depends on package "
    ++ prettyShow (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
    ( mapMaybe
        (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 <- Foldable.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