{-# 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.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.Deprecated.Text
import Text.PrettyPrint
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)

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

import           Distribution.Utils.LogProgress

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

import Data.List
         ( foldl', intercalate )
import qualified Data.Foldable as Foldable (all)
import Data.Maybe
         ( fromMaybe, mapMaybe )
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Compat.Binary (Binary(..))
import GHC.Generics
import Data.Typeable
import Control.Monad
import Control.Exception
         ( assert )
import qualified Data.Map as Map
import           Data.Map (Map)
import qualified Data.Set as Set
import           Data.Set (Set)

import Prelude hiding (lookup)


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

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

-- | Packages in an install plan
--
-- NOTE: 'ConfiguredPackage', 'GenericReadyPackage' and 'GenericPlanPackage'
-- intentionally have no 'PackageInstalled' instance. `This is important:
-- PackageInstalled returns only library dependencies, but for package that
-- aren't yet installed we know many more kinds of dependencies (setup
-- dependencies, exe, test-suite, benchmark, ..). Any functions that operate on
-- dependencies in 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)

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

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

depends :: IsUnit a => a -> [UnitId]
depends = nodeNeighbors

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

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

type PlanPackage = GenericPlanPackage
                   InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)

instance (Package ipkg, Package srcpkg) =>
         Package (GenericPlanPackage ipkg srcpkg) where
  packageId (PreExisting ipkg)     = packageId ipkg
  packageId (Configured  spkg)     = packageId spkg
  packageId (Installed   spkg)     = packageId spkg

instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) =>
         HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where
  mungedId (PreExisting ipkg)     = mungedId ipkg
  mungedId (Configured  spkg)     = mungedId spkg
  mungedId (Installed   spkg)     = mungedId spkg

instance (HasUnitId ipkg, HasUnitId srcpkg) =>
         HasUnitId
         (GenericPlanPackage ipkg srcpkg) where
  installedUnitId (PreExisting ipkg) = installedUnitId ipkg
  installedUnitId (Configured  spkg) = installedUnitId spkg
  installedUnitId (Installed   spkg) = installedUnitId spkg

instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
          HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
    configuredId (PreExisting ipkg) = configuredId ipkg
    configuredId (Configured  spkg) = configuredId spkg
    configuredId (Installed   spkg) = configuredId spkg

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

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

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

internalError :: String -> String -> a
internalError loc msg = error $ "internal error in InstallPlan." ++ loc
                             ++ if null msg then "" else ": " ++ msg

instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
          Binary ipkg, Binary srcpkg)
       => Binary (GenericInstallPlan ipkg srcpkg) where
    put GenericInstallPlan {
              planGraph      = graph,
              planIndepGoals = indepGoals
        } = put (graph, indepGoals)

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

showPlanGraph :: (Package ipkg, Package srcpkg,
                  IsUnit ipkg, IsUnit srcpkg)
              => Graph (GenericPlanPackage ipkg srcpkg) -> String
showPlanGraph graph = renderStyle defaultStyle $
    vcat (map dispPlanPackage (Graph.toList graph))
  where dispPlanPackage p =
            hang (hsep [ text (showPlanPackageTag p)
                       , disp (packageId p)
                       , parens (disp (nodeKey p))]) 2
                 (vcat (map disp (nodeNeighbors p)))

showInstallPlan :: (Package ipkg, Package srcpkg,
                    IsUnit ipkg, IsUnit srcpkg)
                => GenericInstallPlan ipkg srcpkg -> String
showInstallPlan = showPlanGraph . planGraph

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

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

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

toList :: GenericInstallPlan ipkg srcpkg
       -> [GenericPlanPackage ipkg srcpkg]
toList = Graph.toList . planGraph

toMap :: GenericInstallPlan ipkg srcpkg
      -> Map UnitId (GenericPlanPackage ipkg srcpkg)
toMap = Graph.toMap . planGraph

keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
keys = Graph.keys . planGraph

keysSet :: GenericInstallPlan ipkg srcpkg -> Set UnitId
keysSet = Graph.keysSet . planGraph

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

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

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

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

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

-- | Return all the packages in the 'InstallPlan' in reverse topological order.
-- That is, for each package, all dependencies of the package appear first.
--
-- Compared to 'executionOrder', this function returns all the installed and
-- source packages rather than just the source ones. Also, while both this
-- and 'executionOrder' produce reverse topological orderings of the package
-- dependency graph, it is not necessarily exactly the same order.
--
reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg
                        -> [GenericPlanPackage ipkg srcpkg]
reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)


-- | Return the packages in the plan that 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 " ++ display uid)
    mapDep pidMap _ (PlannedId pid)
        | Just pkgs <- Map.lookup pid pidMap = pkgs
        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)
    -- This shouldn't happen, since mapDep should only be called
    -- on neighbor SolverId, which must have all been done already
    -- by the reverse top-sort (we assume the graph is not broken).


fromSolverInstallPlanWithProgress ::
      (IsUnit ipkg, IsUnit srcpkg)
    => (   (SolverId -> [GenericPlanPackage ipkg srcpkg])
        -> SolverInstallPlan.SolverPlanPackage
        -> LogProgress [GenericPlanPackage ipkg srcpkg]         )
    -> SolverInstallPlan
    -> LogProgress (GenericInstallPlan ipkg srcpkg)
fromSolverInstallPlanWithProgress f plan = do
    (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])
                        (SolverInstallPlan.reverseTopologicalOrder plan)
    return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
               (Graph.fromDistinctList pkgs'')
               (SolverInstallPlan.planIndepGoals plan)
  where
    f' (pidMap, ipiMap, pkgs) pkg = do
        pkgs' <- f (mapDep pidMap ipiMap) pkg
        let (pidMap', ipiMap')
                 = case nodeKey pkg of
                    PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
                    PlannedId     pid   -> (Map.insert pid pkgs' pidMap, ipiMap)
        return (pidMap', ipiMap', pkgs' ++ pkgs)

    mapDep _ ipiMap (PreExistingId _pid uid)
        | Just pkgs <- Map.lookup uid ipiMap = pkgs
        | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ display uid)
    mapDep pidMap _ (PlannedId pid)
        | Just pkgs <- Map.lookup pid pidMap = pkgs
        | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ display pid)
    -- This shouldn't happen, since mapDep should only be called
    -- on neighbor SolverId, which must have all been done already
    -- by the reverse top-sort (we assume the graph is not broken).

-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
-- Similar to 'elaboratedInstallPlan'
configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan
configureInstallPlan configFlags solverPlan =
    flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
      [case planpkg of
        SolverInstallPlan.PreExisting pkg ->
          PreExisting (instSolverPkgIPI pkg)

        SolverInstallPlan.Configured  pkg ->
          Configured (configureSolverPackage mapDep pkg)
      ]
  where
    configureSolverPackage :: (SolverId -> [PlanPackage])
                           -> SolverPackage UnresolvedPkgLoc
                           -> ConfiguredPackage UnresolvedPkgLoc
    configureSolverPackage mapDep spkg =
      ConfiguredPackage {
        confPkgId = Configure.computeComponentId
                        (Cabal.fromFlagOrDefault False
                            (Cabal.configDeterministic configFlags))
                        Cabal.NoFlag
                        Cabal.NoFlag
                        (packageId spkg)
                        (PD.CLibName 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 :: (IsUnit ipkg, IsUnit srcpkg)
          => GenericInstallPlan ipkg srcpkg
          -> Processing -> UnitId
          -> ([GenericReadyPackage srcpkg], Processing)
completed plan (Processing processingSet completedSet failedSet) pkgid =
    assert (pkgid `Set.member` processingSet) $
    assert (processingInvariant plan processing') $

    ( map asReadyPackage newlyReady
    , processing' )
  where
    completedSet'  = Set.insert pkgid completedSet

    -- each direct reverse dep where all direct deps are completed
    newlyReady     = [ dep
                     | dep <- revDirectDeps plan pkgid
                     , all ((`Set.member` completedSet') . nodeKey)
                           (directDeps plan (nodeKey dep))
                     ]

    processingSet' = foldl' (flip Set.insert)
                            (Set.delete pkgid processingSet)
                            (map nodeKey newlyReady)
    processing'    = Processing processingSet' completedSet' failedSet

    asReadyPackage (Configured pkg) = ReadyPackage pkg
    asReadyPackage _ = internalError "completed" ""

failed :: (IsUnit ipkg, IsUnit srcpkg)
       => GenericInstallPlan ipkg srcpkg
       -> Processing -> UnitId
       -> ([srcpkg], Processing)
failed plan (Processing processingSet completedSet failedSet) pkgid =
    assert (pkgid `Set.member` processingSet) $
    assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $
    assert (all (`Set.notMember` completedSet)  (tail newlyFailedIds)) $
    -- but note that some newlyFailed may already be in the failed set
    -- since one package can depend on two packages that both fail and
    -- so would be in the rev-dep closure for both.
    assert (processingInvariant plan processing') $

    ( map asConfiguredPackage (tail newlyFailed)
    , processing' )
  where
    processingSet' = Set.delete pkgid processingSet
    failedSet'     = failedSet `Set.union` Set.fromList newlyFailedIds
    newlyFailedIds = map nodeKey newlyFailed
    newlyFailed    = fromMaybe (internalError "failed" "package not in graph")
                   $ Graph.revClosure (planGraph plan) [pkgid]
    processing'    = Processing processingSet' completedSet failedSet'

    asConfiguredPackage (Configured pkg) = pkg
    asConfiguredPackage _ = internalError "failed" "not in configured state"

processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)
                    => GenericInstallPlan ipkg srcpkg
                    -> Processing -> Bool
processingInvariant plan (Processing processingSet completedSet failedSet) =

    -- All the packages in the three sets are actually in the graph
    assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $
    assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $
    assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $

    -- The processing, completed and failed sets are disjoint from each other
    assert (noIntersection processingSet completedSet) $
    assert (noIntersection processingSet failedSet) $
    assert (noIntersection failedSet     completedSet) $

    -- Packages that depend on a package that's still processing cannot be
    -- completed
    assert (noIntersection (reverseClosure processingSet) completedSet) $

    -- On the other hand, packages that depend on a package that's still
    -- processing /can/ have failed (since they may have depended on multiple
    -- packages that were processing, but it only takes one to fail to cause
    -- knock-on failures) so it is quite possible to have an
    -- intersection (reverseClosure processingSet) failedSet

    -- The failed set is upwards closed, i.e. equal to its own rev dep closure
    assert (failedSet == reverseClosure failedSet) $

    -- All immediate reverse deps of packges that are currently processing
    -- are not currently being processed (ie not in the processing set).
    assert (and [ rdeppkgid `Set.notMember` processingSet
                | pkgid     <- Set.toList processingSet
                , rdeppkgid <- maybe (internalError "processingInvariant" "")
                                     (map nodeKey)
                                     (Graph.revNeighbors (planGraph plan) pkgid)
                ]) $

    -- Packages from the processing or failed sets are only ever in the
    -- configured state.
    assert (and [ case Graph.lookup pkgid (planGraph plan) of
                    Just (Configured  _) -> True
                    Just (PreExisting _) -> False
                    Just (Installed   _) -> False
                    Nothing              -> False
                | pkgid <- Set.toList processingSet ++ Set.toList failedSet ])

    -- We use asserts rather than returning False so that on failure we get
    -- better details on which bit of the invariant was violated.
    True
  where
    reverseClosure    = Set.fromList
                      . map nodeKey
                      . fromMaybe (internalError "processingInvariant" "")
                      . Graph.revClosure (planGraph plan)
                      . Set.toList
    noIntersection a b = Set.null (Set.intersection a b)


-- ------------------------------------------------------------
-- * Traversing plans
-- ------------------------------------------------------------

-- | Flatten an 'InstallPlan', producing the sequence of source packages in
-- the order in which they would be processed when the plan is executed. This
-- can be used for simultations or presenting execution dry-runs.
--
-- It is guaranteed to give the same order as using 'execute' (with a serial
-- in-order 'JobControl'), which is a reverse topological orderings of the
-- source packages in the dependency graph, albeit not necessarily exactly the
-- same ordering as that produced by 'reverseTopologicalOrder'.
--
executionOrder :: (IsUnit ipkg, IsUnit srcpkg)
               => GenericInstallPlan ipkg srcpkg
               -> [GenericReadyPackage srcpkg]
executionOrder plan =
    let (newpkgs, processing) = ready plan
     in tryNewTasks processing newpkgs
  where
    tryNewTasks _processing []       = []
    tryNewTasks  processing (p:todo) = waitForTasks processing p todo

    waitForTasks processing p todo =
        p : tryNewTasks processing' (todo++nextpkgs)
      where
        (nextpkgs, processing') = completed plan processing (nodeKey p)


-- ------------------------------------------------------------
-- * Executing plans
-- ------------------------------------------------------------

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

-- | Lookup the build result for a single package.
--
lookupBuildOutcome :: HasUnitId pkg
                   => pkg -> BuildOutcomes failure result
                   -> Maybe (Either failure result)
lookupBuildOutcome = Map.lookup . installedUnitId

-- | Execute an install plan. This traverses the plan in dependency order.
--
-- Executing each individual package can fail and if so all dependents fail
-- too. The result for each package is collected as a 'BuildOutcomes' map.
--
-- Visiting each package happens with optional parallelism, as determined by
-- the 'JobControl'. By default, after any failure we stop as soon as possible
-- (using the 'JobControl' to try to cancel in-progress tasks). This behaviour
-- can be reversed to keep going and build as many packages as possible.
--
-- Note that the 'BuildOutcomes' is /not/ guaranteed to cover all the packages
-- in the plan. In particular in the default mode where we stop as soon as
-- possible after a failure then there may be packages which are skipped and
-- these will have no 'BuildOutcome'.
--
execute :: forall m ipkg srcpkg result failure.
           (IsUnit ipkg, IsUnit srcpkg,
            Monad m)
        => JobControl m (UnitId, Either failure result)
        -> Bool                -- ^ Keep going after failure
        -> (srcpkg -> failure) -- ^ Value for dependents of failed packages
        -> GenericInstallPlan ipkg srcpkg
        -> (GenericReadyPackage srcpkg -> m (Either failure result))
        -> m (BuildOutcomes failure result)
execute jobCtl keepGoing depFailure plan installPkg =
    let (newpkgs, processing) = ready plan
     in tryNewTasks Map.empty False False processing newpkgs
  where
    tryNewTasks :: BuildOutcomes failure result
                -> Bool -> Bool -> Processing
                -> [GenericReadyPackage srcpkg]
                -> m (BuildOutcomes failure result)

    tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs
      -- we were in the process of cancelling and now we're finished
      | tasksFailed && not keepGoing && not tasksRemaining
      = return results

      -- we are still in the process of cancelling, wait for remaining tasks
      | tasksFailed && not keepGoing && tasksRemaining
      = waitForTasks results tasksFailed processing

      -- no new tasks to do and all tasks are done so we're finished
      | null newpkgs && not tasksRemaining
      = return results

      -- no new tasks to do, remaining tasks to wait for
      | null newpkgs
      = waitForTasks results tasksFailed processing

      -- new tasks to do, spawn them, then wait for tasks to complete
      | otherwise
      = do sequence_ [ spawnJob jobCtl $ do
                         result <- installPkg pkg
                         return (nodeKey pkg, result)
                     | pkg <- newpkgs ]
           waitForTasks results tasksFailed processing

    waitForTasks :: BuildOutcomes failure result
                 -> Bool -> Processing
                 -> m (BuildOutcomes failure result)
    waitForTasks !results tasksFailed !processing = do
      (pkgid, result) <- collectJob jobCtl

      case result of

        Right _success -> do
            tasksRemaining <- remainingJobs jobCtl
            tryNewTasks results' tasksFailed tasksRemaining
                        processing' nextpkgs
          where
            results' = Map.insert pkgid result results
            (nextpkgs, processing') = completed plan processing pkgid

        Left _failure -> do
            -- if this is the first failure and we're not trying to keep going
            -- then try to cancel as many of the remaining jobs as possible
            when (not tasksFailed && not keepGoing) $
              cancelJobs jobCtl

            tasksRemaining <- remainingJobs jobCtl
            tryNewTasks results' True tasksRemaining processing' []
          where
            (depsfailed, processing') = failed plan processing pkgid
            results'   = Map.insert pkgid result results `Map.union` depResults
            depResults = Map.fromList
                           [ (nodeKey deppkg, Left (depFailure deppkg))
                           | deppkg <- depsfailed ]

-- ------------------------------------------------------------
-- * Checking validity of plans
-- ------------------------------------------------------------

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

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

showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)
                => PlanProblem ipkg srcpkg -> String
showPlanProblem (PackageMissingDeps pkg missingDeps) =
     "Package " ++ display (nodeKey pkg)
  ++ " depends on the following packages which are missing from the plan: "
  ++ intercalate ", " (map display missingDeps)

showPlanProblem (PackageCycle cycleGroup) =
     "The following packages are involved in a dependency cycle "
  ++ intercalate ", " (map (display . nodeKey) cycleGroup)
showPlanProblem (PackageStateInvalid pkg pkg') =
     "Package " ++ display (nodeKey pkg)
  ++ " is in the " ++ showPlanPackageTag pkg
  ++ " state but it depends on package " ++ display (nodeKey pkg')
  ++ " which is in the " ++ showPlanPackageTag pkg'
  ++ " state"

-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
--
problems :: (IsUnit ipkg, IsUnit srcpkg)
         => Graph (GenericPlanPackage ipkg srcpkg)
         -> [PlanProblem ipkg srcpkg]
problems graph =

     [ PackageMissingDeps pkg
       (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 <- Graph.toList graph
     , Just pkg' <- map (flip Graph.lookup graph)
                    (nodeNeighbors pkg)
     , not (stateDependencyRelation pkg pkg') ]

-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @stateDependencyRelation a b = True@.
--
stateDependencyRelation :: GenericPlanPackage ipkg srcpkg
                        -> GenericPlanPackage ipkg srcpkg -> Bool
stateDependencyRelation PreExisting{} PreExisting{} = True

stateDependencyRelation Installed{}   PreExisting{} = True
stateDependencyRelation Installed{}   Installed{}   = True

stateDependencyRelation Configured{}  PreExisting{} = True
stateDependencyRelation Configured{}  Installed{}   = True
stateDependencyRelation Configured{}  Configured{}  = True

stateDependencyRelation _             _             = False
