CmdTest.hs 9.7 KB
Newer Older
Oleg Grenrus's avatar
Oleg Grenrus committed
1
2
{-# LANGUAGE NamedFieldPuns #-}

3
-- | cabal-install CLI command: test
Oleg Grenrus's avatar
Oleg Grenrus committed
4
5
--
module Distribution.Client.CmdTest (
6
    -- * The @test@ CLI and action
Oleg Grenrus's avatar
Oleg Grenrus committed
7
8
    testCommand,
    testAction,
9
10
11
12
13

    -- * Internals exposed for testing
    TargetProblem(..),
    selectPackageTargets,
    selectComponentTarget
Oleg Grenrus's avatar
Oleg Grenrus committed
14
15
16
  ) where

import Distribution.Client.ProjectOrchestration
17
import Distribution.Client.CmdErrorMessages
Oleg Grenrus's avatar
Oleg Grenrus committed
18
19

import Distribution.Client.Setup
20
         ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags )
21
import qualified Distribution.Client.Setup as Client
Oleg Grenrus's avatar
Oleg Grenrus committed
22
23
24
25
import Distribution.Simple.Setup
         ( HaddockFlags, fromFlagOrDefault )
import Distribution.Simple.Command
         ( CommandUI(..), usageAlternatives )
26
27
import Distribution.Text
         ( display )
28
import Distribution.Verbosity
29
         ( Verbosity, normal )
Oleg Grenrus's avatar
Oleg Grenrus committed
30
import Distribution.Simple.Utils
31
32
33
34
         ( wrapText, die' )

import Control.Monad (when)

Oleg Grenrus's avatar
Oleg Grenrus committed
35
36
37
38

testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
testCommand = Client.installCommand {
  commandName         = "new-test",
39
40
  commandSynopsis     = "Run test-suites",
  commandUsage        = usageAlternatives "new-test" [ "[TARGETS] [FLAGS]" ],
Oleg Grenrus's avatar
Oleg Grenrus committed
41
  commandDescription  = Just $ \_ -> wrapText $
42
43
44
45
46
47
48
49
50
51
52
        "Runs the specified test-suites, first ensuring they are up to "
     ++ "date.\n\n"

     ++ "Any test-suite in any package in the project can be specified. "
     ++ "A package can be specified in which case all the test-suites in the "
     ++ "package are run. The default is to run all the test-suites in the "
     ++ "package in the current directory.\n\n"

     ++ "Dependencies are built or rebuilt as necessary. Additional "
     ++ "configuration flags can be specified on the command line and these "
     ++ "extend the project configuration from the 'cabal.project', "
53
54
55
56
     ++ "'cabal.project.local' and other files.\n\n"

     ++ "To pass command-line arguments to a test suite, see the "
     ++ "new-run command.",
57
  commandNotes        = Just $ \pname ->
Oleg Grenrus's avatar
Oleg Grenrus committed
58
        "Examples:\n"
59
60
61
62
63
64
65
66
67
     ++ "  " ++ pname ++ " new-test\n"
     ++ "    Run all the test-suites in the package in the current directory\n"
     ++ "  " ++ pname ++ " new-test pkgname\n"
     ++ "    Run all the test-suites in the package named pkgname\n"
     ++ "  " ++ pname ++ " new-test cname\n"
     ++ "    Run the test-suite named cname\n"
     ++ "  " ++ pname ++ " new-test cname --enable-coverage\n"
     ++ "    Run the test-suite built with code coverage (including local libs used)\n\n"

68
     ++ cmdCommonHelpTextNewBuildBeta
Oleg Grenrus's avatar
Oleg Grenrus committed
69
70
   }

71

Oleg Grenrus's avatar
Oleg Grenrus committed
72
73
-- | The @test@ command is very much like @build@. It brings the install plan
-- up to date, selects that part of the plan needed by the given or implicit
74
-- test target(s) and then executes the plan.
Oleg Grenrus's avatar
Oleg Grenrus committed
75
76
77
78
79
80
81
82
--
-- Compared to @build@ the difference is that there's also test targets
-- which are ephemeral.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)
83
           -> [String] -> GlobalFlags -> IO ()
84
testAction (configFlags, configExFlags, installFlags, haddockFlags)
Oleg Grenrus's avatar
Oleg Grenrus committed
85
86
           targetStrings globalFlags = do

87
88
    baseCtx <- establishProjectBaseContext verbosity cliConfig

89
90
    targetSelectors <- either (reportTargetSelectorProblems verbosity) return
                   =<< readTargetSelectors (localPackages baseCtx) targetStrings
Oleg Grenrus's avatar
Oleg Grenrus committed
91

92
    buildCtx <-
93
94
95
      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

            when (buildSettingOnlyDeps (buildSettings baseCtx)) $
96
97
98
99
100
              die' verbosity $
                  "The test command does not support '--only-dependencies'. "
               ++ "You may wish to use 'build --only-dependencies' and then "
               ++ "use 'test'."

Oleg Grenrus's avatar
Oleg Grenrus committed
101
102
            -- Interpret the targets on the command line as test targets
            -- (as opposed to say build or haddock targets).
103
            targets <- either (reportTargetProblems verbosity) return
104
                     $ resolveTargets
105
106
107
                         selectPackageTargets
                         selectComponentTarget
                         TargetProblemCommon
108
                         elaboratedPlan
109
                         targetSelectors
110

111
112
            let elaboratedPlan' = pruneInstallPlanToTargets
                                    TargetActionTest
113
                                    targets
114
                                    elaboratedPlan
115
            return (elaboratedPlan', targets)
Oleg Grenrus's avatar
Oleg Grenrus committed
116

117
    printPlan verbosity baseCtx buildCtx
Oleg Grenrus's avatar
Oleg Grenrus committed
118

119
120
    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
Oleg Grenrus's avatar
Oleg Grenrus committed
121
122
  where
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
123
124
125
    cliConfig = commandLineFlagsToProjectConfig
                  globalFlags configFlags configExFlags
                  installFlags haddockFlags
Oleg Grenrus's avatar
Oleg Grenrus committed
126

127
128
129
130
131
132
-- | This defines what a 'TargetSelector' means for the @test@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @test@ command we select all buildable test-suites,
-- or fail if there are no test-suites or no buildable test-suites.
133
--
134
selectPackageTargets  :: TargetSelector
135
                      -> [AvailableTarget k] -> Either TargetProblem [k]
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
selectPackageTargets targetSelector targets

    -- If there are any buildable test-suite targets then we select those
  | not (null targetsTestsBuildable)
  = Right targetsTestsBuildable

    -- If there are test-suites but none are buildable then we report those
  | not (null targetsTests)
  = Left (TargetProblemNoneEnabled targetSelector targetsTests)

    -- If there are no test-suite but some other targets then we report that
  | not (null targets)
  = Left (TargetProblemNoTests targetSelector)

    -- If there are no targets at all then we report that
  | otherwise
  = Left (TargetProblemNoTargets targetSelector)
153
  where
154
155
156
157
158
159
160
161
    targetsTestsBuildable = selectBuildableTargets
                          . filterTargetsKind TestKind
                          $ targets

    targetsTests          = forgetTargetsDetail
                          . filterTargetsKind TestKind
                          $ targets

162

163
164
165
166
167
168
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @test@ command we just need to check it is a test-suite, in addition
-- to the basic checks on being buildable etc.
--
169
selectComponentTarget :: SubComponentTarget
170
                      -> AvailableTarget k -> Either TargetProblem k
171
selectComponentTarget subtarget@WholeComponent t
172
173
  | CTestName _ <- availableTargetComponentName t
  = either (Left . TargetProblemCommon) return $
174
           selectComponentTargetBasic subtarget t
175
  | otherwise
176
177
  = Left (TargetProblemComponentNotTest (availableTargetPackageId t)
                                        (availableTargetComponentName t))
178

179
180
181
182
selectComponentTarget subtarget t
  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)
                                      (availableTargetComponentName t)
                                       subtarget)
183
184
185
186

-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @test@ command.
--
187
188
data TargetProblem =
     TargetProblemCommon       TargetProblemCommon
189
190

     -- | The 'TargetSelector' matches targets but none are buildable
191
   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
192
193

     -- | There are no targets at all
194
   | TargetProblemNoTargets   TargetSelector
195
196

     -- | The 'TargetSelector' matches targets but no test-suites
197
   | TargetProblemNoTests     TargetSelector
198
199
200

     -- | The 'TargetSelector' refers to a component that is not a test-suite
   | TargetProblemComponentNotTest PackageId ComponentName
201
202
203

     -- | Asking to test an individual file or module is not supported
   | TargetProblemIsSubComponent   PackageId ComponentName SubComponentTarget
204
  deriving (Eq, Show)
205

206
207
208
209
210
reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
reportTargetProblems verbosity =
    die' verbosity . unlines . map renderTargetProblem

renderTargetProblem :: TargetProblem -> String
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
renderTargetProblem (TargetProblemCommon problem) =
    renderTargetProblemCommon "run" problem

renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
    renderTargetProblemNoneEnabled "test" targetSelector targets

renderTargetProblem (TargetProblemNoTests targetSelector) =
    "Cannot run tests for the target '" ++ showTargetSelector targetSelector
 ++ "' which refers to " ++ renderTargetSelector targetSelector
 ++ " because "
 ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
 ++ " not contain any test suites."

renderTargetProblem (TargetProblemNoTargets targetSelector) =
    case targetSelectorFilter targetSelector of
      Just kind | kind /= TestKind
        -> "The test command is for running test suites, but the target '"
           ++ showTargetSelector targetSelector ++ "' refers to "
           ++ renderTargetSelector targetSelector ++ "."

      _ -> renderTargetProblemNoTargets "test" targetSelector

renderTargetProblem (TargetProblemComponentNotTest pkgid cname) =
    "The test command is for running test suites, but the target '"
 ++ showTargetSelector targetSelector ++ "' refers to "
 ++ renderTargetSelector targetSelector ++ " from the package "
 ++ display pkgid ++ "."
  where
    targetSelector = TargetComponent pkgid cname WholeComponent

renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
    "The test command can only run test suites as a whole, "
 ++ "not files or modules within them, but the target '"
 ++ showTargetSelector targetSelector ++ "' refers to "
 ++ renderTargetSelector targetSelector ++ "."
  where
    targetSelector = TargetComponent pkgid cname subtarget