cabal-install-solver/src/Distribution/Solver/Modular/Assignment.hs

   1 module Distribution.Solver.Modular.Assignment
   2     ( Assignment(..)
   3     , PAssignment
   4     , FAssignment
   5     , SAssignment
   6     , toCPs
   7     ) where
   8
   9 import Prelude ()
  10 import Distribution.Solver.Compat.Prelude hiding (pi)
  11
  12 import qualified Data.Array as A
  13 import qualified Data.List as L
  14 import qualified Data.Map as M
  15
  16 import Data.Maybe (fromJust)
  17
  18 import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal
  19
  20 import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)
  21 import qualified Distribution.Solver.Types.ComponentDeps as CD
  22 import Distribution.Solver.Types.OptionalStanza
  23 import Distribution.Solver.Types.PackagePath
  24
  25 import Distribution.Solver.Modular.Configured
  26 import Distribution.Solver.Modular.Dependency
  27 import Distribution.Solver.Modular.Flag
  28 import Distribution.Solver.Modular.LabeledGraph
  29 import Distribution.Solver.Modular.Package
  30
  31 -- | A (partial) package assignment. Qualified package names
  32 -- are associated with instances.
  33 type PAssignment    = Map QPN I
  34
  35 type FAssignment    = Map QFN Bool
  36 type SAssignment    = Map QSN Bool
  37
  38 -- | A (partial) assignment of variables.
  39 data Assignment = A PAssignment FAssignment SAssignment
  40   deriving (Show, Eq)
  41
  42 -- | Delivers an ordered list of fully configured packages.
  43 --
  44 -- TODO: This function is (sort of) ok. However, there's an open bug
  45 -- w.r.t. unqualification. There might be several different instances
  46 -- of one package version chosen by the solver, which will lead to
  47 -- clashes.
  48 toCPs :: Assignment -> RevDepMap -> [CP QPN]
  49 toCPs (A pa fa sa) rdm =
  50   let
  51     -- get hold of the graph
  52     g   :: Graph Component
  53     vm  :: Vertex -> ((), QPN, [(Component, QPN)])
  54     cvm :: QPN -> Maybe Vertex
  55     -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.
  56     (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs))
  57                                   (M.toList rdm))
  58     tg :: Graph Component
  59     tg = transposeG g
  60     -- Topsort the dependency graph, yielding a list of pkgs in the right order.
  61     -- The graph will still contain all the installed packages, and it might
  62     -- contain duplicates, because several variables might actually resolve to
  63     -- the same package in the presence of qualified package names.
  64     ps :: [PI QPN]
  65     ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $
  66          topSort g
  67     -- Determine the flags per package, by walking over and regrouping the
  68     -- complete flag assignment by package.
  69     fapp :: Map QPN FlagAssignment
  70     fapp = M.fromListWith mappend $
  71            L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $
  72            M.toList $
  73            fa
  74     -- Stanzas per package.
  75     sapp :: Map QPN OptionalStanzaSet
  76     sapp = M.fromListWith mappend
  77          $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty))
  78          $ M.toList sa
  79     -- Dependencies per package.
  80     depp :: QPN -> [(Component, PI QPN)]
  81     depp qpn = let v :: Vertex
  82                    v   = fromJust (cvm qpn) -- TODO: why this is safe?
  83                    dvs :: [(Component, Vertex)]
  84                    dvs = tg A.! v
  85                in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs
  86     -- Translated to PackageDeps
  87     depp' :: QPN -> ComponentDeps [PI QPN]
  88     depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp
  89   in
  90     L.map (\ pi@(PI qpn _) -> CP pi
  91                                  (M.findWithDefault mempty qpn fapp)
  92                                  (M.findWithDefault mempty qpn sapp)
  93                                  (depp' qpn))
  94           ps