-
Notifications
You must be signed in to change notification settings - Fork 681
/
Test.hs
295 lines (273 loc) · 8.55 KB
/
Test.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Test
-- Copyright : Isaac Jones 2003-2004
-- Duncan Coutts 2007
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Definition of the testing command-line options.
-- See: @Distribution.Simple.Setup@
module Distribution.Simple.Setup.Test
( TestFlags (..)
, emptyTestFlags
, defaultTestFlags
, testCommand
, TestShowDetails (..)
, testOptions'
) where
import Distribution.Compat.Prelude hiding (get)
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
import Distribution.Parsec
import Distribution.Pretty
import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
import Distribution.Simple.InstallDirs
import Distribution.Simple.Utils
import Distribution.Verbosity
import qualified Text.PrettyPrint as Disp
import Distribution.ModuleName (ModuleName)
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
-- * Test flags
-- ------------------------------------------------------------
data TestShowDetails = Never | Failures | Always | Streaming | Direct
deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable)
instance Binary TestShowDetails
instance Structured TestShowDetails
knownTestShowDetails :: [TestShowDetails]
knownTestShowDetails = [minBound .. maxBound]
instance Pretty TestShowDetails where
pretty = Disp.text . lowercase . show
instance Parsec TestShowDetails where
parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident
where
ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-')
classify str = lookup (lowercase str) enumMap
enumMap :: [(String, TestShowDetails)]
enumMap =
[ (prettyShow x, x)
| x <- knownTestShowDetails
]
-- TODO: do we need this instance?
instance Monoid TestShowDetails where
mempty = Never
mappend = (<>)
instance Semigroup TestShowDetails where
a <> b = if a < b then b else a
data TestFlags = TestFlags
{ testDistPref :: Flag FilePath
, testVerbosity :: Flag Verbosity
, testHumanLog :: Flag PathTemplate
, testMachineLog :: Flag PathTemplate
, testShowDetails :: Flag TestShowDetails
, testKeepTix :: Flag Bool
, testWrapper :: Flag FilePath
, testFailWhenNoTestSuites :: Flag Bool
, testCoverageLibsModules :: Flag [ModuleName]
-- ^ The list of all modules from libraries in the local project that should
-- be included in the hpc coverage report.
, testCoverageDistPrefs :: Flag [FilePath]
-- ^ The path to each library local to this project and to the test
-- components being built, to include in coverage reporting (notably, this
-- excludes indefinite libraries and instantiations because HPC does not
-- support backpack - Nov. 2023). Cabal uses these paths as dist prefixes to
-- determine the path to the `mix` dirs of each component to cover.
, -- TODO: think about if/how options are passed to test exes
testOptions :: [PathTemplate]
}
deriving (Show, Generic, Typeable)
defaultTestFlags :: TestFlags
defaultTestFlags =
TestFlags
{ testDistPref = NoFlag
, testVerbosity = Flag normal
, testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log"
, testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log"
, testShowDetails = toFlag Direct
, testKeepTix = toFlag False
, testWrapper = NoFlag
, testFailWhenNoTestSuites = toFlag False
, testCoverageLibsModules = NoFlag
, testCoverageDistPrefs = NoFlag
, testOptions = []
}
testCommand :: CommandUI TestFlags
testCommand =
CommandUI
{ commandName = "test"
, commandSynopsis =
"Run all/specific tests in the test suite."
, commandDescription = Just $ \_pname ->
wrapText $
testOrBenchmarkHelpText "test"
, commandNotes = Nothing
, commandUsage =
usageAlternatives
"test"
[ "[FLAGS]"
, "TESTCOMPONENTS [FLAGS]"
]
, commandDefaultFlags = defaultTestFlags
, commandOptions = testOptions'
}
testOptions' :: ShowOrParseArgs -> [OptionField TestFlags]
testOptions' showOrParseArgs =
[ optionVerbosity testVerbosity (\v flags -> flags{testVerbosity = v})
, optionDistPref
testDistPref
(\d flags -> flags{testDistPref = d})
showOrParseArgs
, option
[]
["log"]
( "Log all test suite results to file (name template can use "
++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)"
)
testHumanLog
(\v flags -> flags{testHumanLog = v})
( reqArg'
"TEMPLATE"
(toFlag . toPathTemplate)
(flagToList . fmap fromPathTemplate)
)
, option
[]
["machine-log"]
( "Produce a machine-readable log file (name template can use "
++ "$pkgid, $compiler, $os, $arch, $result)"
)
testMachineLog
(\v flags -> flags{testMachineLog = v})
( reqArg'
"TEMPLATE"
(toFlag . toPathTemplate)
(flagToList . fmap fromPathTemplate)
)
, option
[]
["show-details"]
( "'always': always show results of individual test cases. "
++ "'never': never show results of individual test cases. "
++ "'failures': show results of failing test cases. "
++ "'streaming': show results of test cases in real time."
++ "'direct': send results of test cases in real time; no log file."
)
testShowDetails
(\v flags -> flags{testShowDetails = v})
( reqArg
"FILTER"
( parsecToReadE
( \_ ->
"--show-details flag expects one of "
++ intercalate
", "
(map prettyShow knownTestShowDetails)
)
(fmap toFlag parsec)
)
(flagToList . fmap prettyShow)
)
, option
[]
["keep-tix-files"]
"keep .tix files for HPC between test runs"
testKeepTix
(\v flags -> flags{testKeepTix = v})
trueArg
, option
[]
["test-wrapper"]
"Run test through a wrapper."
testWrapper
(\v flags -> flags{testWrapper = v})
( reqArg'
"FILE"
(toFlag :: FilePath -> Flag FilePath)
(flagToList :: Flag FilePath -> [FilePath])
)
, option
[]
["fail-when-no-test-suites"]
("Exit with failure when no test suites are found.")
testFailWhenNoTestSuites
(\v flags -> flags{testFailWhenNoTestSuites = v})
trueArg
, option
[]
["coverage-module"]
"Module of a project-local library to include in the HPC report"
testCoverageLibsModules
( \v flags ->
flags
{ testCoverageLibsModules =
mergeListFlag (testCoverageLibsModules flags) v
}
)
( reqArg'
"MODULE"
(Flag . (: []) . fromString)
(fmap prettyShow . fromFlagOrDefault [])
)
, option
[]
["coverage-dist-dir"]
"The directory where Cabal puts generated build files of an HPC enabled component"
testCoverageDistPrefs
( \v flags ->
flags
{ testCoverageDistPrefs =
mergeListFlag (testCoverageDistPrefs flags) v
}
)
( reqArg'
"DIR"
(Flag . (: []))
(fromFlagOrDefault [])
)
, option
[]
["test-options"]
( "give extra options to test executables "
++ "(name templates can use $pkgid, $compiler, "
++ "$os, $arch, $test-suite)"
)
testOptions
(\v flags -> flags{testOptions = v})
( reqArg'
"TEMPLATES"
(map toPathTemplate . splitArgs)
(const [])
)
, option
[]
["test-option"]
( "give extra option to test executables "
++ "(no need to quote options containing spaces, "
++ "name template can use $pkgid, $compiler, "
++ "$os, $arch, $test-suite)"
)
testOptions
(\v flags -> flags{testOptions = v})
( reqArg'
"TEMPLATE"
(\x -> [toPathTemplate x])
(map fromPathTemplate)
)
]
emptyTestFlags :: TestFlags
emptyTestFlags = mempty
instance Monoid TestFlags where
mempty = gmempty
mappend = (<>)
instance Semigroup TestFlags where
(<>) = gmappend