module Distribution.Solver.Modular.Assignment
    ( Assignment(..)
    , PAssignment
    , FAssignment
    , SAssignment
    , toCPs
    ) where

import Prelude ()
import Distribution.Solver.Compat.Prelude hiding (pi)

import qualified Data.Array as A
import qualified Data.List as L
import qualified Data.Map as M

import Data.Maybe (fromJust)

import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal

import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath

import Distribution.Solver.Modular.Configured
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.LabeledGraph
import Distribution.Solver.Modular.Package

-- | A (partial) package assignment. Qualified package names
-- are associated with instances.
type PAssignment    = Map QPN I

type FAssignment    = Map QFN Bool
type SAssignment    = Map QSN Bool

-- | A (partial) assignment of variables.
data Assignment = A PAssignment FAssignment SAssignment
  deriving (Vertex -> Assignment -> ShowS
[Assignment] -> ShowS
Assignment -> String
forall a.
(Vertex -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Assignment] -> ShowS
$cshowList :: [Assignment] -> ShowS
show :: Assignment -> String
$cshow :: Assignment -> String
showsPrec :: Vertex -> Assignment -> ShowS
$cshowsPrec :: Vertex -> Assignment -> ShowS
Show, Assignment -> Assignment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Assignment -> Assignment -> Bool
$c/= :: Assignment -> Assignment -> Bool
== :: Assignment -> Assignment -> Bool
$c== :: Assignment -> Assignment -> Bool
Eq)

-- | Delivers an ordered list of fully configured packages.
--
-- TODO: This function is (sort of) ok. However, there's an open bug
-- w.r.t. unqualification. There might be several different instances
-- of one package version chosen by the solver, which will lead to
-- clashes.
toCPs :: Assignment -> RevDepMap -> [CP QPN]
toCPs :: Assignment -> RevDepMap -> [CP QPN]
toCPs (A PAssignment
pa FAssignment
fa SAssignment
sa) RevDepMap
rdm =
  let
    -- get hold of the graph
    g   :: Graph Component
    vm  :: Vertex -> ((), QPN, [(Component, QPN)])
    cvm :: QPN -> Maybe Vertex
    -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub.
    (Graph Component
g, Vertex -> ((), QPN, [(Component, QPN)])
vm, QPN -> Maybe Vertex
cvm) = forall key node edge.
Ord key =>
[(node, key, [(edge, key)])]
-> (Graph edge, Vertex -> (node, key, [(edge, key)]),
    key -> Maybe Vertex)
graphFromEdges (forall a b. (a -> b) -> [a] -> [b]
L.map (\ (QPN
x, [(Component, QPN)]
xs) -> ((), QPN
x, forall a. Eq a => [a] -> [a]
nub [(Component, QPN)]
xs))
                                  (forall k a. Map k a -> [(k, a)]
M.toList RevDepMap
rdm))
    tg :: Graph Component
    tg :: Graph Component
tg = forall e. Graph e -> Graph e
transposeG Graph Component
g
    -- Topsort the dependency graph, yielding a list of pkgs in the right order.
    -- The graph will still contain all the installed packages, and it might
    -- contain duplicates, because several variables might actually resolve to
    -- the same package in the presence of qualified package names.
    ps :: [PI QPN]
    ps :: [PI QPN]
ps = forall a b. (a -> b) -> [a] -> [b]
L.map ((\ (()
_, QPN
x, [(Component, QPN)]
_) -> forall qpn. qpn -> I -> PI qpn
PI QPN
x (PAssignment
pa forall k a. Ord k => Map k a -> k -> a
M.! QPN
x)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vertex -> ((), QPN, [(Component, QPN)])
vm) forall a b. (a -> b) -> a -> b
$
         forall e. Graph e -> [Vertex]
topSort Graph Component
g
    -- Determine the flags per package, by walking over and regrouping the
    -- complete flag assignment by package.
    fapp :: Map QPN FlagAssignment
    fapp :: Map QPN FlagAssignment
fapp = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Monoid a => a -> a -> a
mappend forall a b. (a -> b) -> a -> b
$
           forall a b. (a -> b) -> [a] -> [b]
L.map (\ ((FN QPN
qpn Flag
fn), Bool
b) -> (QPN
qpn, [(Flag, Bool)] -> FlagAssignment
mkFlagAssignment [(Flag
fn, Bool
b)])) forall a b. (a -> b) -> a -> b
$
           forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$
           FAssignment
fa
    -- Stanzas per package.
    sapp :: Map QPN OptionalStanzaSet
    sapp :: Map QPN OptionalStanzaSet
sapp = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith forall a. Monoid a => a -> a -> a
mappend
         forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
L.map (\ ((SN QPN
qpn Stanza
sn), Bool
b) -> (QPN
qpn, if Bool
b then Stanza -> OptionalStanzaSet
optStanzaSetSingleton Stanza
sn else forall a. Monoid a => a
mempty))
         forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList SAssignment
sa
    -- Dependencies per package.
    depp :: QPN -> [(Component, PI QPN)]
    depp :: QPN -> [(Component, PI QPN)]
depp QPN
qpn = let v :: Vertex
                   v :: Vertex
v   = forall a. HasCallStack => Maybe a -> a
fromJust (QPN -> Maybe Vertex
cvm QPN
qpn) -- TODO: why this is safe?
                   dvs :: [(Component, Vertex)]
                   dvs :: [(Component, Vertex)]
dvs = Graph Component
tg forall i e. Ix i => Array i e -> i -> e
A.! Vertex
v
               in forall a b. (a -> b) -> [a] -> [b]
L.map (\ (Component
comp, Vertex
dv) -> case Vertex -> ((), QPN, [(Component, QPN)])
vm Vertex
dv of (()
_, QPN
x, [(Component, QPN)]
_) -> (Component
comp, forall qpn. qpn -> I -> PI qpn
PI QPN
x (PAssignment
pa forall k a. Ord k => Map k a -> k -> a
M.! QPN
x))) [(Component, Vertex)]
dvs
    -- Translated to PackageDeps
    depp' :: QPN -> ComponentDeps [PI QPN]
    depp' :: QPN -> ComponentDeps [PI QPN]
depp' = forall a. Monoid a => [ComponentDep a] -> ComponentDeps a
CD.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
L.map (\(Component
comp, PI QPN
d) -> (Component
comp, [PI QPN
d])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. QPN -> [(Component, PI QPN)]
depp
  in
    forall a b. (a -> b) -> [a] -> [b]
L.map (\ pi :: PI QPN
pi@(PI QPN
qpn I
_) -> forall qpn.
PI qpn
-> FlagAssignment
-> OptionalStanzaSet
-> ComponentDeps [PI qpn]
-> CP qpn
CP PI QPN
pi
                                 (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty QPN
qpn Map QPN FlagAssignment
fapp)
                                 (forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault forall a. Monoid a => a
mempty QPN
qpn Map QPN OptionalStanzaSet
sapp)
                                 (QPN -> ComponentDeps [PI QPN]
depp' QPN
qpn))
          [PI QPN]
ps