-- | These graph traversal functions mirror the ones in Cabal, but work with
-- the more complete (and fine-grained) set of dependencies provided by
-- PackageFixedDeps rather than only the library dependencies provided by
-- PackageInstalled.
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Distribution.Client.PlanIndex (
    -- * FakeMap and related operations
    FakeMap
  , fakeDepends
  , fakeLookupUnitId
    -- * Graph traversal functions
  , brokenPackages
  , dependencyCycles
  , dependencyGraph
  , dependencyInconsistencies
  ) where

import Prelude hiding (lookup)
import qualified Data.Map as Map
import qualified Data.Graph as Graph
import Data.Array ((!))
import Data.Map (Map)
import Data.Maybe (isNothing)
import Data.Either (rights)

#if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(..))
#endif

import Distribution.Package
         ( PackageName(..), PackageIdentifier(..), UnitId(..)
         , Package(..), packageName, packageVersion
         )
import Distribution.Version
         ( Version )

import Distribution.Client.ComponentDeps (ComponentDeps)
import qualified Distribution.Client.ComponentDeps as CD
import Distribution.Client.Types
         ( PackageFixedDeps(..) )
import Distribution.Simple.PackageIndex
         ( PackageIndex, allPackages, insert, lookupUnitId )
import Distribution.Package
         ( HasUnitId(..), PackageId )

-- Note [FakeMap]
-----------------
-- We'd like to use the PackageIndex defined in this module for cabal-install's
-- InstallPlan.  However, at the moment, this data structure is indexed by
-- UnitId, which we don't know until after we've compiled a package
-- (whereas InstallPlan needs to store not-compiled packages in the index.)
-- Eventually, an UnitId will be calculatable prior to actually building
-- the package, but at the moment, the "fake installed package ID map" is a
-- workaround to solve this problem while reusing PackageIndex.  The basic idea
-- is that, since we don't know what an UnitId is beforehand, we just fake
-- up one based on the package ID (it only needs to be unique for the particular
-- install plan), and fill it out with the actual generated UnitId after
-- the package is successfully compiled.
--
-- However, there is a problem: in the index there may be references using the
-- old package ID, which are now dangling if we update the UnitId.  We
-- could map over the entire index to update these pointers as well (a costly
-- operation), but instead, we've chosen to parametrize a variety of important
-- functions by a FakeMap, which records what a fake installed package ID was
-- actually resolved to post-compilation.  If we do a lookup, we first check and
-- see if it's a fake ID in the FakeMap.
--
-- It's a bit grungy, but we expect this to only be temporary anyway.  (Another
-- possible workaround would have been to *not* update the installed package ID,
-- but I decided this would be hard to understand.)

-- | Map from fake package keys to real ones.  See Note [FakeMap]
type FakeMap = Map UnitId UnitId

-- | Variant of `depends` which accepts a `FakeMap`
--
-- Analogous to `fakeInstalledDepends`. See Note [FakeMap].
fakeDepends :: PackageFixedDeps pkg => FakeMap -> pkg -> ComponentDeps [UnitId]
fakeDepends fakeMap = fmap (map resolveFakeId) . depends
  where
    resolveFakeId :: UnitId -> UnitId
    resolveFakeId ipid = Map.findWithDefault ipid ipid fakeMap

--- | Variant of 'lookupUnitId' which accepts a 'FakeMap'.  See Note
--- [FakeMap].
fakeLookupUnitId :: FakeMap -> PackageIndex a -> UnitId
                             -> Maybe a
fakeLookupUnitId fakeMap index pkg =
  lookupUnitId index (Map.findWithDefault pkg pkg fakeMap)

-- | All packages that have dependencies that are not in the index.
--
-- Returns such packages along with the dependencies that they're missing.
--
brokenPackages :: (PackageFixedDeps pkg)
               => FakeMap
               -> PackageIndex pkg
               -> [(pkg, [UnitId])]
brokenPackages fakeMap index =
  [ (pkg, missing)
  | pkg  <- allPackages index
  , let missing =
          [ pkg' | pkg' <- CD.flatDeps (depends pkg)
                 , isNothing (fakeLookupUnitId fakeMap index pkg') ]
  , not (null missing) ]

-- | Compute all roots of the install plan, and verify that the transitive
-- plans from those roots are all consistent.
--
-- NOTE: This does not check for dependency cycles. Moreover, dependency cycles
-- may be absent from the subplans even if the larger plan contains a dependency
-- cycle. Such cycles may or may not be an issue; either way, we don't check
-- for them here.
dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasUnitId pkg)
                          => FakeMap
                          -> Bool
                          -> PackageIndex pkg
                          -> [(PackageName, [(PackageIdentifier, Version)])]
dependencyInconsistencies fakeMap indepGoals index  =
    concatMap (dependencyInconsistencies' fakeMap) subplans
  where
    subplans :: [PackageIndex pkg]
    subplans = rights $
                 map (dependencyClosure fakeMap index)
                     (rootSets fakeMap indepGoals index)

-- | Compute the root sets of a plan
--
-- A root set is a set of packages whose dependency closure must be consistent.
-- This is the set of all top-level library roots (taken together normally, or
-- as singletons sets if we are considering them as independent goals), along
-- with all setup dependencies of all packages.
rootSets :: (PackageFixedDeps pkg, HasUnitId pkg)
         => FakeMap -> Bool -> PackageIndex pkg -> [[UnitId]]
rootSets fakeMap indepGoals index =
       if indepGoals then map (:[]) libRoots else [libRoots]
    ++ setupRoots index
  where
    libRoots = libraryRoots fakeMap index

-- | Compute the library roots of a plan
--
-- The library roots are the set of packages with no reverse dependencies
-- (no reverse library dependencies but also no reverse setup dependencies).
libraryRoots :: (PackageFixedDeps pkg, HasUnitId pkg)
             => FakeMap -> PackageIndex pkg -> [UnitId]
libraryRoots fakeMap index =
    map toPkgId roots
  where
    (graph, toPkgId, _) = dependencyGraph fakeMap index
    indegree = Graph.indegree graph
    roots    = filter isRoot (Graph.vertices graph)
    isRoot v = indegree ! v == 0

-- | The setup dependencies of each package in the plan
setupRoots :: PackageFixedDeps pkg => PackageIndex pkg -> [[UnitId]]
setupRoots = filter (not . null)
           . map (CD.setupDeps . depends)
           . allPackages

-- | Given a package index where we assume we want to use all the packages
-- (use 'dependencyClosure' if you need to get such a index subset) find out
-- if the dependencies within it use consistent versions of each package.
-- Return all cases where multiple packages depend on different versions of
-- some other package.
--
-- Each element in the result is a package name along with the packages that
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
--
dependencyInconsistencies' :: forall pkg.
                              (PackageFixedDeps pkg, HasUnitId pkg)
                           => FakeMap
                           -> PackageIndex pkg
                           -> [(PackageName, [(PackageIdentifier, Version)])]
dependencyInconsistencies' fakeMap index =
    [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids])
    | (name, ipid_map) <- Map.toList inverseIndex
    , let uses = Map.elems ipid_map
    , reallyIsInconsistent (map fst uses)
    ]
  where
    -- For each package name (of a dependency, somewhere)
    --   and each installed ID of that that package
    --     the associated package instance
    --     and a list of reverse dependencies (as source IDs)
    inverseIndex :: Map PackageName (Map UnitId (pkg, [PackageId]))
    inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))
      [ (packageName dep, Map.fromList [(ipid,(dep,[packageId pkg]))])
      | -- For each package @pkg@
        pkg <- allPackages index
        -- Find out which @ipid@ @pkg@ depends on
      , ipid <- CD.nonSetupDeps (fakeDepends fakeMap pkg)
        -- And look up those @ipid@ (i.e., @ipid@ is the ID of @dep@)
      , Just dep <- [fakeLookupUnitId fakeMap index ipid]
      ]

    -- If, in a single install plan, we depend on more than one version of a
    -- package, then this is ONLY okay in the (rather special) case that we
    -- depend on precisely two versions of that package, and one of them
    -- depends on the other. This is necessary for example for the base where
    -- we have base-3 depending on base-4.
    reallyIsInconsistent :: [pkg] -> Bool
    reallyIsInconsistent []       = False
    reallyIsInconsistent [_p]     = False
    reallyIsInconsistent [p1, p2] =
      let pid1 = installedUnitId p1
          pid2 = installedUnitId p2
      in Map.findWithDefault pid1 pid1 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p2)
      && Map.findWithDefault pid2 pid2 fakeMap `notElem` CD.nonSetupDeps (fakeDepends fakeMap p1)
    reallyIsInconsistent _ = True



-- | Find if there are any cycles in the dependency graph. If there are no
-- cycles the result is @[]@.
--
-- This actually computes the strongly connected components. So it gives us a
-- list of groups of packages where within each group they all depend on each
-- other, directly or indirectly.
--
dependencyCycles :: (PackageFixedDeps pkg, HasUnitId pkg)
                 => FakeMap
                 -> PackageIndex pkg
                 -> [[pkg]]
dependencyCycles fakeMap index =
  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
  where
    adjacencyList = [ (pkg, installedUnitId pkg,
                            CD.flatDeps (fakeDepends fakeMap pkg))
                    | pkg <- allPackages index ]


-- | Tries to take the transitive closure of the package dependencies.
--
-- If the transitive closure is complete then it returns that subset of the
-- index. Otherwise it returns the broken packages as in 'brokenPackages'.
--
-- * Note that if the result is @Right []@ it is because at least one of
-- the original given 'PackageIdentifier's do not occur in the index.
dependencyClosure :: (PackageFixedDeps pkg, HasUnitId pkg)
                  => FakeMap
                  -> PackageIndex pkg
                  -> [UnitId]
                  -> Either [(pkg, [UnitId])]
                            (PackageIndex pkg)
dependencyClosure fakeMap index pkgids0 = case closure mempty [] pkgids0 of
  (completed, []) -> Right completed
  (completed, _)  -> Left (brokenPackages fakeMap completed)
 where
    closure completed failed []             = (completed, failed)
    closure completed failed (pkgid:pkgids) =
      case fakeLookupUnitId fakeMap index pkgid of
        Nothing   -> closure completed (pkgid:failed) pkgids
        Just pkg  ->
          case fakeLookupUnitId fakeMap completed
               (installedUnitId pkg) of
            Just _  -> closure completed  failed pkgids
            Nothing -> closure completed' failed pkgids'
              where completed' = insert pkg completed
                    pkgids'    = CD.nonSetupDeps (depends pkg) ++ pkgids


-- | Builds a graph of the package dependencies.
--
-- Dependencies on other packages that are not in the index are discarded.
-- You can check if there are any such dependencies with 'brokenPackages'.
--
dependencyGraph :: (PackageFixedDeps pkg, HasUnitId pkg)
                => FakeMap
                -> PackageIndex pkg
                -> (Graph.Graph,
                    Graph.Vertex -> UnitId,
                    UnitId -> Maybe Graph.Vertex)
dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex)
  where
    (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges
    vertexToPkg v = case vertexToPkg' v of
                      ((), pkgid, _targets) -> pkgid

    pkgs  = allPackages index
    edges = map edgesFrom pkgs

    resolve   pid = Map.findWithDefault pid pid fakeMap
    edgesFrom pkg = ( ()
                    , resolve (installedUnitId pkg)
                    , CD.flatDeps (fakeDepends fakeMap pkg)
                    )
