Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
d3259408
Commit
d3259408
authored
Jul 11, 2016
by
Edward Z. Yang
Browse files
Revert "Add Distribution.Compat.Graph, fixes #3521."
This reverts commit
4f796f22
.
parent
b9fdc1bf
Changes
7
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
,
pkg
Build
ableComponents
,
pkg
En
able
d
Components
,
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