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

   1 {-# LANGUAGE TypeFamilies #-}
   2 module Distribution.Solver.Modular.Cycles (
   3     detectCyclesPhase
   4   ) where
   5
   6 import Prelude hiding (cycle)
   7 import qualified Data.Map as M
   8 import qualified Data.Set as S
   9
  10 import qualified Distribution.Compat.Graph as G
  11 import Distribution.Simple.Utils (ordNub)
  12 import Distribution.Solver.Modular.Dependency
  13 import Distribution.Solver.Modular.Flag
  14 import Distribution.Solver.Modular.Tree
  15 import qualified Distribution.Solver.Modular.ConflictSet as CS
  16 import Distribution.Solver.Types.ComponentDeps (Component)
  17 import Distribution.Solver.Types.PackagePath
  18
  19 -- | Find and reject any nodes with cyclic dependencies
  20 detectCyclesPhase :: Tree d c -> Tree d c
  21 detectCyclesPhase = go
  22   where
  23     -- Only check children of choice nodes.
  24     go :: Tree d c -> Tree d c
  25     go (PChoice qpn rdm gr                         cs) =
  26         PChoice qpn rdm gr     $ fmap (checkChild qpn)   (fmap go cs)
  27     go (FChoice qfn@(FN qpn _) rdm gr w m d cs) =
  28         FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs)
  29     go (SChoice qsn@(SN qpn _) rdm gr w     cs) =
  30         SChoice qsn rdm gr w   $ fmap (checkChild qpn)   (fmap go cs)
  31     go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs)
  32     go x@(Fail _ _) = x
  33     go x@(Done _ _) = x
  34
  35     checkChild :: QPN -> Tree d c -> Tree d c
  36     checkChild qpn x@(PChoice _  rdm _       _) = failIfCycle qpn rdm x
  37     checkChild qpn x@(FChoice _  rdm _ _ _ _ _) = failIfCycle qpn rdm x
  38     checkChild qpn x@(SChoice _  rdm _ _     _) = failIfCycle qpn rdm x
  39     checkChild qpn x@(GoalChoice rdm         _) = failIfCycle qpn rdm x
  40     checkChild _   x@(Fail _ _)                 = x
  41     checkChild qpn x@(Done       rdm _)         = failIfCycle qpn rdm x
  42
  43     failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c
  44     failIfCycle qpn rdm x =
  45       case findCycles qpn rdm of
  46         Nothing     -> x
  47         Just relSet -> Fail relSet CyclicDependencies
  48
  49 -- | Given the reverse dependency map from a node in the tree, check
  50 -- if the solution is cyclic. If it is, return the conflict set containing
  51 -- all decisions that could potentially break the cycle.
  52 --
  53 -- TODO: The conflict set should also contain flag and stanza variables.
  54 findCycles :: QPN -> RevDepMap -> Maybe ConflictSet
  55 findCycles pkg rdm =
  56     -- This function has two parts: a faster cycle check that is called at every
  57     -- step and a slower calculation of the conflict set.
  58     --
  59     -- 'hasCycle' checks for cycles incrementally by only looking for cycles
  60     -- containing the current package, 'pkg'. It searches for cycles in the
  61     -- 'RevDepMap', which is the data structure used to store reverse
  62     -- dependencies in the search tree. We store the reverse dependencies in a
  63     -- map, because Data.Map is smaller and/or has better sharing than
  64     -- Distribution.Compat.Graph.
  65     --
  66     -- If there is a cycle, we call G.cycles to find a strongly connected
  67     -- component. Then we choose one cycle from the component to use for the
  68     -- conflict set. Choosing only one cycle can lead to a smaller conflict set,
  69     -- such as when a choice to enable testing introduces many cycles at once.
  70     -- In that case, all cycles contain the current package and are in one large
  71     -- strongly connected component.
  72     --
  73     if hasCycle
  74     then let scc :: G.Graph RevDepMapNode
  75              scc = case G.cycles $ revDepMapToGraph rdm of
  76                      []    -> findCyclesError "cannot find a strongly connected component"
  77                      c : _ -> G.fromDistinctList c
  78
  79              next :: QPN -> QPN
  80              next p = case G.neighbors scc p of
  81                         Just (n : _) -> G.nodeKey n
  82                         _            -> findCyclesError "cannot find next node in the cycle"
  83
  84              -- This function also assumes that all cycles contain 'pkg'.
  85              oneCycle :: [QPN]
  86              oneCycle = case iterate next pkg of
  87                           []     -> findCyclesError "empty cycle"
  88                           x : xs -> x : takeWhile (/= x) xs
  89          in Just $ CS.fromList $ map P oneCycle
  90     else Nothing
  91   where
  92     hasCycle :: Bool
  93     hasCycle = pkg `S.member` closure (neighbors pkg)
  94
  95     closure :: [QPN] -> S.Set QPN
  96     closure = foldl go S.empty
  97       where
  98         go :: S.Set QPN -> QPN -> S.Set QPN
  99         go s x =
 100             if x `S.member` s
 101             then s
 102             else foldl go (S.insert x s) $ neighbors x
 103
 104     neighbors :: QPN -> [QPN]
 105     neighbors x = case x `M.lookup` rdm of
 106                     Nothing -> findCyclesError "cannot find node"
 107                     Just xs -> map snd xs
 108
 109     findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++)
 110
 111 data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)]
 112
 113 instance G.IsNode RevDepMapNode where
 114   type Key RevDepMapNode = QPN
 115   nodeKey (RevDepMapNode qpn _) = qpn
 116   nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns
 117
 118 revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode
 119 revDepMapToGraph rdm = G.fromDistinctList
 120                        [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm]