Skip to content

GitLab

Commit d3259408 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Revert "Add Distribution.Compat.Graph, fixes #3521." 

This reverts commit 4f796f22.
parent b9fdc1bf
Hide whitespace changes
Inline Side-by-side
Cabal/Cabal.cabal
View file @ d3259408
......@@ -273,7 +273,6 @@ library
Distribution.Compat.CreatePipe
Distribution.Compat.Environment
Distribution.Compat.Exception
Distribution.Compat.Graph
Distribution.Compat.Internal.TempFile
Distribution.Compat.ReadP
Distribution.Compat.Semigroup
......@@ -378,7 +377,6 @@ test-suite unit-tests
UnitTests.Distribution.Compat.CreatePipe
UnitTests.Distribution.Compat.ReadP
UnitTests.Distribution.Compat.Time
UnitTests.Distribution.Compat.Graph
UnitTests.Distribution.Simple.Program.Internal
UnitTests.Distribution.Simple.Utils
UnitTests.Distribution.System
......@@ -386,9 +384,7 @@ test-suite unit-tests
UnitTests.Distribution.Version
main-is: UnitTests.hs
build-depends:
array,
base,
containers,
directory,
filepath,
tasty,
......
Cabal/Distribution/Compat/Graph.hs deleted 100644 → 0
View file @ b9fdc1bf
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.Graph
-- Copyright : (c) Edward Z. Yang 2016
-- License : BSD3
--
-- Maintainer : cabal-dev@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- A data type representing directed graphs, backed by "Data.Graph".
-- It is strict in the node type.
--
-- This is an alternative interface to "Data.Graph". In this interface,
-- nodes (identified by the 'IsNode' type class) are associated with a
-- key and record the keys of their neighbors. This interface is more
-- convenient than 'Data.Graph.Graph', which requires vertices to be
-- explicitly handled by integer indexes.
--
-- The current implementation has somewhat peculiar performance
-- characteristics. The asymptotics of all map-like operations mirror
-- their counterparts in "Data.Map". However, to perform a graph
-- operation, we first must build the "Data.Graph" representation, an
-- operation that takes /O(V + E log V)/. However, this operation can
-- be amortized across all queries on that particular graph.
--
-- Some nodes may be broken, i.e., refer to neighbors which are not
-- stored in the graph. In our graph algorithms, we transparently
-- ignore such edges; however, you can easily query for the broken
-- vertices of a graph using 'broken' (and should, e.g., to ensure that
-- a closure of a graph is well-formed.) It's possible to take a closed
-- subset of a broken graph and get a well-formed graph.
--
-----------------------------------------------------------------------------
module Distribution.Compat.Graph (
-- * Graph type
Graph,
IsNode(..),
-- * Query
null,
size,
lookup,
-- * Construction
empty,
insert,
deleteKey,
deleteLookup,
-- * Combine
unionLeft,
unionRight,
-- * Graph algorithms
stronglyConnComp,
SCC(..),
cycles,
broken,
closure,
revClosure,
topSort,
revTopSort,
-- * Conversions
-- ** Maps
toMap,
-- ** Lists
fromList,
toList,
keys,
-- ** Graphs
toGraph,
-- * Node type
Node(..),
nodeValue,
) where
import qualified Prelude as Prelude
import Prelude hiding (lookup, null)
import Data.Graph (SCC(..))
import qualified Data.Graph as G
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Array as Array
import Data.Array ((!))
import qualified Data.Tree as Tree
import Data.Either
import Data.Typeable
import qualified Data.Foldable as Foldable
import Control.DeepSeq
import Distribution.Compat.Binary (Binary(..))
-- | A graph of nodes @a@. The nodes are expected to have instance
-- of class 'IsNode'.
data Graph a
= Graph {
graphMap :: !(Map (Key a) a),
-- Lazily cached graph representation
graphForward :: G.Graph,
graphAdjoint :: G.Graph,
graphVertexToNode :: G.Vertex -> a,
graphKeyToVertex :: Key a -> Maybe G.Vertex,
graphBroken :: [(a, [Key a])]
}
deriving (Typeable)
-- NB: Not a Functor! (or Traversable), because you need
-- to restrict Key a ~ Key b. We provide our own mapping
-- functions.
-- General strategy is most operations are deferred to the
-- Map representation.
instance Show a => Show (Graph a) where
show = show . toList
instance (IsNode a, Read a) => Read (Graph a) where
readsPrec d s = map (\(a,r) -> (fromList a, r)) (readsPrec d s)
instance (IsNode a, Binary a) => Binary (Graph a) where
put x = put (toList x)
get = fmap fromList get
instance (Eq (Key a), Eq a) => Eq (Graph a) where
g1 == g2 = graphMap g1 == graphMap g2
instance Foldable.Foldable Graph where
fold = Foldable.fold . graphMap
foldr f z = Foldable.foldr f z . graphMap
foldl f z = Foldable.foldl f z . graphMap
foldMap f = Foldable.foldMap f . graphMap
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,6,0)
foldl' f z = Foldable.foldl' f z . graphMap
foldr' f z = Foldable.foldr' f z . graphMap
#endif
#if MIN_VERSION_base(4,8,0)
length = Foldable.length . graphMap
null = Foldable.null . graphMap
toList = Foldable.toList . graphMap
elem x = Foldable.elem x . graphMap
maximum = Foldable.maximum . graphMap
minimum = Foldable.minimum . graphMap
sum = Foldable.sum . graphMap
product = Foldable.product . graphMap
#endif
#endif
instance (NFData a, NFData (Key a)) => NFData (Graph a) where
rnf Graph {
graphMap = m,
graphForward = gf,
graphAdjoint = ga,
graphVertexToNode = vtn,
graphKeyToVertex = ktv,
graphBroken = b
} = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m
-- TODO: Data instance?
-- | The 'IsNode' class is used for datatypes which represent directed
-- graph nodes. A node of type @a@ is associated with some unique key of
-- type @'Key' a@; given a node we can determine its key ('nodeKey')
-- and the keys of its neighbors ('nodeNeighbors').
class Ord (Key a) => IsNode a where
type Key a :: *
nodeKey :: a -> Key a
nodeNeighbors :: a -> [Key a]
-- | A simple, trivial data type which admits an 'IsNode' instance.
data Node k a = N a k [k]
deriving (Show, Eq)
-- | Get the value from a 'Node'.
nodeValue :: Node k a -> a
nodeValue (N a _ _) = a
instance Functor (Node k) where
fmap f (N a k ks) = N (f a) k ks
instance Ord k => IsNode (Node k a) where
type Key (Node k a) = k
nodeKey (N _ k _) = k
nodeNeighbors (N _ _ ks) = ks
-- TODO: Maybe introduce a typeclass for items with just
-- keys (so, Key associated type, and nodeKey method). But
-- I didn't need it here, so I didn't introduce it.
-- Query
-- | /O(1)/. Is the graph empty?
null :: Graph a -> Bool
null = Map.null . toMap
-- | /O(1)/. The number of nodes in the graph.
size :: Graph a -> Int
size = Map.size . toMap
-- | /O(log V)/. Lookup the node at a key in the graph.
lookup :: IsNode a => Key a -> Graph a -> Maybe a
lookup k g = Map.lookup k (toMap g)
-- Construction
-- | /O(1)/. The empty graph.
empty :: IsNode a => Graph a
empty = fromMap Map.empty
-- | /O(log V)/. Insert a node into a graph.
insert :: IsNode a => a -> Graph a -> Graph a
insert !n g = fromMap (Map.insert (nodeKey n) n (toMap g))
-- | /O(log V)/. Delete the node at a key from the graph.
deleteKey :: IsNode a => Key a -> Graph a -> Graph a
deleteKey k g = fromMap (Map.delete k (toMap g))
-- | /O(log V)/. Lookup and delete. This function returns the deleted
-- value if it existed.
deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a)
deleteLookup k g =
let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g)
in (r, fromMap m')
-- Combining
-- | /O(V + V')/. Right-biased union, preferring entries
-- from the second map when conflicts occur.
-- @'nodeKey' x = 'nodeKey' (f x)@.
unionRight :: IsNode a => Graph a -> Graph a -> Graph a
unionRight g g' = fromMap (Map.union (toMap g') (toMap g))
-- | /O(V + V')/. Left-biased union, preferring entries from
-- the first map when conflicts occur.
unionLeft :: IsNode a => Graph a -> Graph a -> Graph a
unionLeft g g' = fromMap (Map.union (toMap g) (toMap g'))
-- Graph-like operations
-- | /Ω(V + E)/. Compute the strongly connected components of a graph.
-- Requires amortized construction of graph.
stronglyConnComp :: Graph a -> [SCC a]
stronglyConnComp g = map decode forest
where
forest = G.scc (graphForward g)
decode (Tree.Node v [])
| mentions_itself v = CyclicSCC [graphVertexToNode g v]
| otherwise = AcyclicSCC (graphVertexToNode g v)
decode other = CyclicSCC (dec other [])
where dec (Tree.Node v ts) vs
= graphVertexToNode g v : foldr dec vs ts
mentions_itself v = v `elem` (graphForward g ! v)
-- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'.
-- | /Ω(V + E)/. Compute the cycles of a graph.
-- Requires amortized construction of graph.
cycles :: Graph a -> [[a]]
cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ]
-- | /O(1)/. Return a list of nodes paired with their broken
-- neighbors (i.e., neighbor keys which are not in the graph).
-- Requires amortized construction of graph.
broken :: Graph a -> [(a, [Key a])]
broken g = graphBroken g
-- | Compute the subgraph which is the closure of some set of keys.
-- Returns @Nothing@ if one (or more) keys are not present in
-- the graph.
-- Requires amortized construction of graph.
closure :: Graph a -> [Key a] -> Maybe [a]
closure g ks = do
vs <- mapM (graphKeyToVertex g) ks
return (decodeVertexForest g (G.dfs (graphForward g) vs))
-- | Compute the reverse closure of a graph from some set
-- of keys. Returns @Nothing@ if one (or more) keys are not present in
-- the graph.
-- Requires amortized construction of graph.
revClosure :: Graph a -> [Key a] -> Maybe [a]
revClosure g ks = do
vs <- mapM (graphKeyToVertex g) ks
return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))
flattenForest :: Tree.Forest a -> [a]
flattenForest = concatMap Tree.flatten
decodeVertexForest :: Graph a -> Tree.Forest G.Vertex -> [a]
decodeVertexForest g = map (graphVertexToNode g) . flattenForest
-- | Topologically sort the nodes of a graph.
-- Requires amortized construction of graph.
topSort :: Graph a -> [a]
topSort g = map (graphVertexToNode g) $ G.topSort (graphForward g)
-- | Reverse topologically sort the nodes of a graph.
-- Requires amortized construction of graph.
revTopSort :: Graph a -> [a]
revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)
-- Conversions
-- | /O(1)/. Convert a map from keys to nodes into a graph.
-- The map must satisfy the invariant that
-- @'fromMap' m == 'fromList' ('Data.Map.elems' m)@;
-- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@
-- instead. The values of the map are assumed to already
-- be in WHNF.
fromMap :: IsNode a => Map (Key a) a -> Graph a
fromMap m
= Graph { graphMap = m
-- These are lazily computed!
, graphForward = g
, graphAdjoint = G.transposeG g
, graphVertexToNode = vertex_to_node
, graphKeyToVertex = key_to_vertex
, graphBroken = broke
}
where
try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)
(brokenEdges, edges)
= unzip
$ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
| n <- ns ]
broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)
g = Array.listArray bounds edges
ns = Map.elems m -- sorted ascending
vertices = zip (map nodeKey ns) [0..]
vertex_map = Map.fromAscList vertices
key_to_vertex k = Map.lookup k vertex_map
vertex_to_node vertex = nodeTable ! vertex
nodeTable = Array.listArray bounds ns
bounds = (0, Map.size m - 1)
-- | /O(V log V)/. Convert a list of nodes into a graph.
fromList :: IsNode a => [a] -> Graph a
fromList ns = fromMap
. Map.fromList
. map (\n -> n `seq` (nodeKey n, n))
$ ns
-- Map-like operations
-- | /O(V)/. Convert a graph into a list of nodes.
toList :: Graph a -> [a]
toList g = Map.elems (toMap g)
-- | /O(V)/. Convert a graph into a list of keys.
keys :: Graph a -> [Key a]
keys g = Map.keys (toMap g)
-- | /O(1)/. Convert a graph into a map from keys to nodes.
-- The resulting map @m@ is guaranteed to have the property that
-- @'Prelude.all' (\(k,n) -> k == 'nodeKey' n) ('Data.Map.toList' m)@.
toMap :: Graph a -> Map (Key a) a
toMap = graphMap
-- Graph-like operations
-- | /O(1)/. Convert a graph into a 'Data.Graph.Graph'.
-- Requires amortized construction of graph.
toGraph :: Graph a -> (G.Graph, G.Vertex -> a, Key a -> Maybe G.Vertex)
toGraph g = (graphForward g, graphVertexToNode g, graphKeyToVertex g)
Cabal/Distribution/PackageDescription.hs
View file @ d3259408
......@@ -62,7 +62,9 @@ module Distribution.PackageDescription (
knownTestTypes,
emptyTestSuite,
hasTests,
withTest,
testModules,
enabledTests,
-- * Benchmarks
Benchmark(..),
......@@ -72,7 +74,9 @@ module Distribution.PackageDescription (
knownBenchmarkTypes,
emptyBenchmark,
hasBenchmarks,
withBenchmark,
benchmarkModules,
enabledBenchmarks,
-- * Build information
BuildInfo(..),
......@@ -549,7 +553,13 @@ exeModules exe = otherModules (buildInfo exe)
data TestSuite = TestSuite {
testName :: String,
testInterface :: TestSuiteInterface,
testBuildInfo :: BuildInfo
testBuildInfo :: BuildInfo,
testEnabled :: Bool
-- TODO: By having a 'testEnabled' field in the PackageDescription, we
-- are mixing build status information (i.e., arguments to 'configure')
-- with static package description information. This is undesirable, but
-- a better solution is waiting on the next overhaul to the
-- GenericPackageDescription -> PackageDescription resolution process.
}
deriving (Generic, Show, Read, Eq, Typeable, Data)
......@@ -587,7 +597,8 @@ instance Monoid TestSuite where
mempty = TestSuite {
testName = mempty,
testInterface = mempty,
testBuildInfo = mempty
testBuildInfo = mempty,
testEnabled = False
}
mappend = (Semi.<>)
......@@ -595,7 +606,8 @@ instance Semigroup TestSuite where
a <> b = TestSuite {
testName = combine' testName,
testInterface = combine testInterface,
testBuildInfo = combine testBuildInfo
testBuildInfo = combine testBuildInfo,
testEnabled = testEnabled a || testEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
......@@ -619,6 +631,15 @@ emptyTestSuite = mempty
hasTests :: PackageDescription -> Bool
hasTests = any (buildable . testBuildInfo) . testSuites
-- | Get all the enabled test suites from a package.
enabledTests :: PackageDescription -> [TestSuite]
enabledTests = filter testEnabled . testSuites
-- | Perform an action on each buildable 'TestSuite' in a package.
withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
withTest pkg_descr f =
mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
-- | Get all the module names from a test suite.
testModules :: TestSuite -> [ModuleName]
testModules test = (case testInterface test of
......@@ -678,7 +699,9 @@ testType test = case testInterface test of
data Benchmark = Benchmark {
benchmarkName :: String,
benchmarkInterface :: BenchmarkInterface,
benchmarkBuildInfo :: BuildInfo
benchmarkBuildInfo :: BuildInfo,
benchmarkEnabled :: Bool
-- TODO: See TODO for 'testEnabled'.
}
deriving (Generic, Show, Read, Eq, Typeable, Data)
......@@ -712,7 +735,8 @@ instance Monoid Benchmark where
mempty = Benchmark {
benchmarkName = mempty,
benchmarkInterface = mempty,
benchmarkBuildInfo = mempty
benchmarkBuildInfo = mempty,
benchmarkEnabled = False
}
mappend = (Semi.<>)
......@@ -720,7 +744,8 @@ instance Semigroup Benchmark where
a <> b = Benchmark {
benchmarkName = combine' benchmarkName,
benchmarkInterface = combine benchmarkInterface,
benchmarkBuildInfo = combine benchmarkBuildInfo
benchmarkBuildInfo = combine benchmarkBuildInfo,
benchmarkEnabled = benchmarkEnabled a || benchmarkEnabled b
}
where combine field = field a `mappend` field b
combine' f = case (f a, f b) of
......@@ -744,6 +769,15 @@ emptyBenchmark = mempty
hasBenchmarks :: PackageDescription -> Bool
hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
-- | Get all the enabled benchmarks from a package.
enabledBenchmarks :: PackageDescription -> [Benchmark]
enabledBenchmarks = filter benchmarkEnabled . benchmarks
-- | Perform an action on each buildable 'Benchmark' in a package.
withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
withBenchmark pkg_descr f =
mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr
-- | Get all the module names from a benchmark.
benchmarkModules :: Benchmark -> [ModuleName]
benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
......@@ -905,10 +939,12 @@ allBuildInfo pkg_descr = [ bi | lib <- libraries pkg_descr
, buildable bi ]
++ [ bi | tst <- testSuites pkg_descr
, let bi = testBuildInfo tst
, buildable bi ]
, buildable bi
, testEnabled tst ]
++ [ bi | tst <- benchmarks pkg_descr
, let bi = benchmarkBuildInfo tst
, buildable bi ]
, buildable bi
, benchmarkEnabled tst ]
--FIXME: many of the places where this is used, we actually want to look at
-- unbuildable bits too, probably need separate functions
......
Cabal/Distribution/Simple/LocalBuildInfo.hs
View file @ d3259408
......@@ -38,9 +38,11 @@ module Distribution.Simple.LocalBuildInfo (
foldComponent,
componentName,
componentBuildInfo,
componentBuildable,
componentEnabled,
componentDisabledReason,
ComponentDisabledReason(..),
pkgComponents,
pkgBuildableComponents,
pkgEnabledComponents,
lookupComponent,
getComponent,
maybeGetDefaultLibraryLocalBuildInfo,
......@@ -57,7 +59,6 @@ module Distribution.Simple.LocalBuildInfo (
withLibLBI,
withExeLBI,
withTestLBI,
testLBIs,
-- * Installation directories
module Distribution.Simple.InstallDirs,
......@@ -257,11 +258,28 @@ pkgComponents pkg =
-- Thus this excludes non-buildable components and test suites or benchmarks
-- that have been disabled.
--
pkgBuildableComponents :: PackageDescription -> [Component]
pkgBuildableComponents = filter componentBuildable . pkgComponents
componentBuildable :: Component -> Bool
componentBuildable = buildable . componentBuildInfo
pkgEnabledComponents :: PackageDescription -> [Component]
pkgEnabledComponents = filter componentEnabled . pkgComponents
componentEnabled :: Component -> Bool
componentEnabled = isNothing . componentDisabledReason
data ComponentDisabledReason = DisabledComponent
| DisabledAllTests
| DisabledAllBenchmarks
componentDisabledReason :: Component -> Maybe ComponentDisabledReason
componentDisabledReason (CLib lib)
| not (buildable (libBuildInfo lib)) = Just DisabledComponent
componentDisabledReason (CExe exe)
| not (buildable (buildInfo exe)) = Just DisabledComponent
componentDisabledReason (CTest tst)
| not (buildable (testBuildInfo tst)) = Just DisabledComponent
| not (testEnabled tst) = Just DisabledAllTests
componentDisabledReason (CBench bm)
| not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent
| not (benchmarkEnabled bm) = Just DisabledAllBenchmarks
componentDisabledReason _ = Nothing
lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
lookupComponent pkg (CLibName "") = lookupComponent pkg (defaultLibName (package pkg))
......@@ -428,9 +446,6 @@ withTestLBI pkg lbi f =
| (clbi@TestComponentLocalBuildInfo{}, _) <- componentsConfigs lbi
, CTest test <- [getComponent pkg (componentLocalName clbi)] ]
testLBIs :: LocalBuildInfo -> [ComponentLocalBuildInfo]
testLBIs lbi = [ clbi | (clbi@TestComponentLocalBuildInfo{}, _) <- componentsConfigs lbi ]
{-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-}
withComponentsLBI :: PackageDescription -> LocalBuildInfo
-> (Component -> ComponentLocalBuildInfo -> IO ())
......
Cabal/Distribution/Simple/Test.hs
View file @ d3259408
......@@ -49,7 +49,9 @@ test args pkg_descr lbi flags = do
testLogDir = distPref </> "test"
testNames = args
pkgTests = PD.testSuites pkg_descr
enabledTestLBIs = testLBIs lbi
enabledTests = [ t | t <- pkgTests
, PD.testEnabled t
, PD.buildable (PD.testBuildInfo t) ]
doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog
doTest (suite, _) =
......@@ -76,17 +78,10 @@ test args pkg_descr lbi flags = do
notice verbosity "Package has no test suites."
exitWith ExitSuccess
-- TODO: When we support configuring only a single component, we
-- should refine the message here
when (PD.hasTests pkg_descr && null enabledTestLBIs) $
when (PD.hasTests pkg_descr && null enabledTests) $
die $ "No test suites enabled. Did you remember to configure with "
++ "\'--enable-tests\'?"
targets <- readBuildTargets pkg_descr args
targets' <- checkBuildTargets verbosity pkg_descr targets