Commit 9eca2c62 authored by Edsko de Vries's avatar Edsko de Vries
Browse files

Add `conflictSetOrigin` debugging field

This field is only added if the `debug-conflict-sets` flag is specified to
`cabal config`; it adds a tree to `CallStack`s to a `ConflictSet`. This is very
useful when trying to understand how a certain conflict set was constructed.
parent 58aea459
{-# LANGUAGE CPP #-}
#ifdef DEBUG_CONFLICT_SETS
{-# LANGUAGE ImplicitParams #-}
#endif
-- | Conflict sets
--
-- Intended for double import
......@@ -7,6 +10,9 @@
-- > import qualified Distribution.Solver.Modular.ConflictSet as CS
module Distribution.Solver.Modular.ConflictSet (
ConflictSet -- opaque
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin
#endif
, showCS
-- Set-like operations
, toList
......@@ -23,8 +29,14 @@ module Distribution.Solver.Modular.ConflictSet (
import Prelude hiding (filter)
import Data.List (intercalate)
import Data.Set (Set)
import Data.Function (on)
import qualified Data.Set as S
#ifdef DEBUG_CONFLICT_SETS
import Data.Tree
import GHC.Stack
#endif
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Var
......@@ -32,8 +44,31 @@ import Distribution.Solver.Modular.Var
--
-- Since these variables should be preprocessed in some way, this type is
-- kept abstract.
newtype ConflictSet qpn = CS { fromConflictSet :: Set (Var qpn) }
deriving (Eq, Ord, Show)
data ConflictSet qpn = CS {
-- | The set of variables involved on the conflict
conflictSetToSet :: Set (Var qpn)
#ifdef DEBUG_CONFLICT_SETS
-- | The origin of the conflict set
--
-- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,
-- we record the origin of every conflict set. For new conflict sets
-- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations
-- that construct new conflict sets from existing conflict sets ('union',
-- 'filter', ..) we record the 'CallStack' to the call to the combinator
-- as well as the 'CallStack's of the input conflict sets.
--
-- Requires @GHC >= 7.10@.
, conflictSetOrigin :: Tree CallStack
#endif
}
deriving (Show)
instance Eq qpn => Eq (ConflictSet qpn) where
(==) = (==) `on` conflictSetToSet
instance Ord qpn => Ord (ConflictSet qpn) where
compare = compare `on` conflictSetToSet
showCS :: ConflictSet QPN -> String
showCS = intercalate ", " . map showVar . toList
......@@ -43,32 +78,94 @@ showCS = intercalate ", " . map showVar . toList
-------------------------------------------------------------------------------}
toList :: ConflictSet qpn -> [Var qpn]
toList = S.toList . fromConflictSet
toList = S.toList . conflictSetToSet
union :: Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn
union (CS a) (CS b) = CS (a `S.union` b)
union ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => ConflictSet qpn -> ConflictSet qpn -> ConflictSet qpn
union cs cs' = CS {
conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs')
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])
#endif
}
unions :: Ord qpn => [ConflictSet qpn] -> ConflictSet qpn
unions = CS . S.unions . map fromConflictSet
unions ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => [ConflictSet qpn] -> ConflictSet qpn
unions css = CS {
conflictSetToSet = S.unions (map conflictSetToSet css)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc (map conflictSetOrigin css)
#endif
}
insert :: Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
insert var (CS set) = CS (S.insert (simplifyVar var) set)
insert ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => Var qpn -> ConflictSet qpn -> ConflictSet qpn
insert var cs = CS {
conflictSetToSet = S.insert (simplifyVar var) (conflictSetToSet cs)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc [conflictSetOrigin cs]
#endif
}
empty :: ConflictSet qpn
empty = CS S.empty
empty ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
ConflictSet qpn
empty = CS {
conflictSetToSet = S.empty
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc []
#endif
}
singleton :: Var qpn -> ConflictSet qpn
singleton = CS . S.singleton . simplifyVar
singleton ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Var qpn -> ConflictSet qpn
singleton var = CS {
conflictSetToSet = S.singleton (simplifyVar var)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc []
#endif
}
member :: Ord qpn => Var qpn -> ConflictSet qpn -> Bool
member var (CS set) = S.member (simplifyVar var) set
member var = S.member (simplifyVar var) . conflictSetToSet
#if MIN_VERSION_containers(0,5,0)
filter :: (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
#else
filter :: Ord qpn => (Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
filter ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
#if !MIN_VERSION_containers(0,5,0)
Ord qpn =>
#endif
(Var qpn -> Bool) -> ConflictSet qpn -> ConflictSet qpn
filter p cs = CS {
conflictSetToSet = S.filter p (conflictSetToSet cs)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc [conflictSetOrigin cs]
#endif
filter p (CS set) = CS $ S.filter p set
}
fromList :: Ord qpn => [Var qpn] -> ConflictSet qpn
fromList = CS . S.fromList . map simplifyVar
fromList ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => [Var qpn] -> ConflictSet qpn
fromList vars = CS {
conflictSetToSet = S.fromList (map simplifyVar vars)
#ifdef DEBUG_CONFLICT_SETS
, conflictSetOrigin = Node ?loc []
#endif
}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
#ifdef DEBUG_CONFLICT_SETS
{-# LANGUAGE ImplicitParams #-}
#endif
module Distribution.Solver.Modular.Dependency (
-- * Variables
Var(..)
......@@ -56,6 +60,10 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.ComponentDeps (Component(..))
#ifdef DEBUG_CONFLICT_SETS
import GHC.Stack (CallStack)
#endif
{-------------------------------------------------------------------------------
Constrained instances
-------------------------------------------------------------------------------}
......@@ -85,7 +93,11 @@ showCI (Constrained vr) = showVR (collapse vr)
-- set in the sense the it contains variables that allow us to backjump
-- further. We might apply some heuristics here, such as to change the
-- order in which we check the constraints.
merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
merge ::
#ifdef DEBUG_CONFLICT_SETS
(?loc :: CallStack) =>
#endif
Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
merge c@(Fixed i g1) d@(Fixed j g2)
| i == j = Right c
| otherwise = Left (CS.union (varToConflictSet g1) (varToConflictSet g2), (c, d))
......
......@@ -130,6 +130,10 @@ Flag network-uri
description: Get Network.URI from the network-uri package
default: True
Flag debug-conflict-sets
description: Add additional information to ConflictSets
default: False
executable cabal
main-is: Main.hs
ghc-options: -Wall -fwarn-tabs
......@@ -310,6 +314,10 @@ executable cabal
if !(arch(arm) && impl(ghc < 7.6))
ghc-options: -threaded
if flag(debug-conflict-sets)
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >= 4.8
default-language: Haskell2010
-- Small, fast running tests.
......@@ -377,6 +385,11 @@ Test-Suite unit-tests
if !(arch(arm) && impl(ghc < 7.6))
ghc-options: -threaded
if flag(debug-conflict-sets)
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >= 4.8
default-language: Haskell2010
-- Slow solver tests
......@@ -431,6 +444,11 @@ Test-Suite solver-quickcheck
if !(arch(arm) && impl(ghc < 7.6))
ghc-options: -threaded
if flag(debug-conflict-sets)
cpp-options: -DDEBUG_CONFLICT_SETS
build-depends: base >= 4.8
default-language: Haskell2010
test-suite integration-tests
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment