cabal-install/src/Distribution/Client/CmdTest.hs

   1 {-# LANGUAGE RecordWildCards #-}
   2
   3 -- | cabal-install CLI command: test
   4 module Distribution.Client.CmdTest
   5   ( -- * The @test@ CLI and action
   6     testCommand
   7   , testAction
   8
   9     -- * Internals exposed for testing
  10   , isSubComponentProblem
  11   , notTestProblem
  12   , noTestsProblem
  13   , selectPackageTargets
  14   , selectComponentTarget
  15   ) where
  16
  17 import Distribution.Client.Compat.Prelude
  18 import Prelude ()
  19
  20 import Distribution.Client.CmdErrorMessages
  21   ( plural
  22   , renderTargetProblem
  23   , renderTargetProblemNoTargets
  24   , renderTargetSelector
  25   , showTargetSelector
  26   , targetSelectorFilter
  27   , targetSelectorPluralPkgs
  28   )
  29 import Distribution.Client.NixStyleOptions
  30   ( NixStyleFlags (..)
  31   , defaultNixStyleFlags
  32   , nixStyleOptions
  33   )
  34 import Distribution.Client.ProjectOrchestration
  35 import Distribution.Client.Setup
  36   ( ConfigFlags (..)
  37   , GlobalFlags (..)
  38   )
  39 import Distribution.Client.TargetProblem
  40   ( TargetProblem (..)
  41   )
  42 import Distribution.Client.Utils
  43   ( giveRTSWarning
  44   )
  45 import Distribution.Simple.Command
  46   ( CommandUI (..)
  47   , usageAlternatives
  48   )
  49 import Distribution.Simple.Flag
  50   ( Flag (..)
  51   )
  52 import Distribution.Simple.Setup
  53   ( TestFlags (..)
  54   , fromFlagOrDefault
  55   )
  56 import Distribution.Simple.Utils
  57   ( dieWithException
  58   , notice
  59   , warn
  60   , wrapText
  61   )
  62 import Distribution.Verbosity
  63   ( normal
  64   )
  65
  66 import qualified System.Exit (exitSuccess)
  67
  68 import Distribution.Client.Errors
  69 import Distribution.Client.Setup (CommonSetupFlags (..))
  70 import GHC.Environment
  71   ( getFullArgs
  72   )
  73
  74 testCommand :: CommandUI (NixStyleFlags ())
  75 testCommand =
  76   CommandUI
  77     { commandName = "v2-test"
  78     , commandSynopsis = "Run test-suites."
  79     , commandUsage = usageAlternatives "v2-test" ["[TARGETS] [FLAGS]"]
  80     , commandDescription = Just $ \_ ->
  81         wrapText $
  82           "Runs the specified test-suites, first ensuring they are up to "
  83             ++ "date.\n\n"
  84             ++ "Any test-suite in any package in the project can be specified. "
  85             ++ "A package can be specified in which case all the test-suites in the "
  86             ++ "package are run. The default is to run all the test-suites in the "
  87             ++ "package in the current directory.\n\n"
  88             ++ "Dependencies are built or rebuilt as necessary. Additional "
  89             ++ "configuration flags can be specified on the command line and these "
  90             ++ "extend the project configuration from the 'cabal.project', "
  91             ++ "'cabal.project.local' and other files.\n\n"
  92             ++ "To pass command-line arguments to a test suite, see the "
  93             ++ "v2-run command."
  94     , commandNotes = Just $ \pname ->
  95         "Examples:\n"
  96           ++ "  "
  97           ++ pname
  98           ++ " v2-test\n"
  99           ++ "    Run all the test-suites in the package in the current directory\n"
 100           ++ "  "
 101           ++ pname
 102           ++ " v2-test pkgname\n"
 103           ++ "    Run all the test-suites in the package named pkgname\n"
 104           ++ "  "
 105           ++ pname
 106           ++ " v2-test cname\n"
 107           ++ "    Run the test-suite named cname\n"
 108           ++ "  "
 109           ++ pname
 110           ++ " v2-test cname --enable-coverage\n"
 111           ++ "    Run the test-suite built with code coverage (including local libs used)\n"
 112     , commandDefaultFlags = defaultNixStyleFlags ()
 113     , commandOptions = nixStyleOptions (const [])
 114     }
 115
 116 -- | The @test@ command is very much like @build@. It brings the install plan
 117 -- up to date, selects that part of the plan needed by the given or implicit
 118 -- test target(s) and then executes the plan.
 119 --
 120 -- Compared to @build@ the difference is that there's also test targets
 121 -- which are ephemeral.
 122 --
 123 -- For more details on how this works, see the module
 124 -- "Distribution.Client.ProjectOrchestration"
 125 testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
 126 testAction flags@NixStyleFlags{..} targetStrings globalFlags = do
 127   baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
 128
 129   targetSelectors <-
 130     either (reportTargetSelectorProblems verbosity) return
 131       =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings
 132
 133   buildCtx <-
 134     runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
 135       when (buildSettingOnlyDeps (buildSettings baseCtx)) $
 136         dieWithException verbosity TestCommandDoesn'tSupport
 137
 138       fullArgs <- getFullArgs
 139       when ("+RTS" `elem` fullArgs) $
 140         warn verbosity $
 141           giveRTSWarning "test"
 142
 143       -- Interpret the targets on the command line as test targets
 144       -- (as opposed to say build or haddock targets).
 145       targets <-
 146         either (reportTargetProblems verbosity failWhenNoTestSuites) return $
 147           resolveTargets
 148             selectPackageTargets
 149             selectComponentTarget
 150             elaboratedPlan
 151             Nothing
 152             targetSelectors
 153
 154       let elaboratedPlan' =
 155             pruneInstallPlanToTargets
 156               TargetActionTest
 157               targets
 158               elaboratedPlan
 159       return (elaboratedPlan', targets)
 160
 161   printPlan verbosity baseCtx buildCtx
 162
 163   buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
 164   runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
 165   where
 166     failWhenNoTestSuites = testFailWhenNoTestSuites testFlags
 167     verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
 168     cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags
 169
 170 -- | This defines what a 'TargetSelector' means for the @test@ command.
 171 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 172 -- or otherwise classifies the problem.
 173 --
 174 -- For the @test@ command we select all buildable test-suites,
 175 -- or fail if there are no test-suites or no buildable test-suites.
 176 selectPackageTargets
 177   :: TargetSelector
 178   -> [AvailableTarget k]
 179   -> Either TestTargetProblem [k]
 180 selectPackageTargets targetSelector targets
 181   -- If there are any buildable test-suite targets then we select those
 182   | not (null targetsTestsBuildable) =
 183       Right targetsTestsBuildable
 184   -- If there are test-suites but none are buildable then we report those
 185   | not (null targetsTests) =
 186       Left (TargetProblemNoneEnabled targetSelector targetsTests)
 187   -- If there are no test-suite but some other targets then we report that
 188   | not (null targets) =
 189       Left (noTestsProblem targetSelector)
 190   -- If there are no targets at all then we report that
 191   | otherwise =
 192       Left (TargetProblemNoTargets targetSelector)
 193   where
 194     targetsTestsBuildable =
 195       selectBuildableTargets
 196         . filterTargetsKind TestKind
 197         $ targets
 198
 199     targetsTests =
 200       forgetTargetsDetail
 201         . filterTargetsKind TestKind
 202         $ targets
 203
 204 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
 205 -- selected.
 206 --
 207 -- For the @test@ command we just need to check it is a test-suite, in addition
 208 -- to the basic checks on being buildable etc.
 209 selectComponentTarget
 210   :: SubComponentTarget
 211   -> AvailableTarget k
 212   -> Either TestTargetProblem k
 213 selectComponentTarget subtarget@WholeComponent t
 214   | CTestName _ <- availableTargetComponentName t =
 215       either Left return $
 216         selectComponentTargetBasic subtarget t
 217   | otherwise =
 218       Left
 219         ( notTestProblem
 220             (availableTargetPackageId t)
 221             (availableTargetComponentName t)
 222         )
 223 selectComponentTarget subtarget t =
 224   Left
 225     ( isSubComponentProblem
 226         (availableTargetPackageId t)
 227         (availableTargetComponentName t)
 228         subtarget
 229     )
 230
 231 -- | The various error conditions that can occur when matching a
 232 -- 'TargetSelector' against 'AvailableTarget's for the @test@ command.
 233 data TestProblem
 234   = -- | The 'TargetSelector' matches targets but no test-suites
 235     TargetProblemNoTests TargetSelector
 236   | -- | The 'TargetSelector' refers to a component that is not a test-suite
 237     TargetProblemComponentNotTest PackageId ComponentName
 238   | -- | Asking to test an individual file or module is not supported
 239     TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
 240   deriving (Eq, Show)
 241
 242 type TestTargetProblem = TargetProblem TestProblem
 243
 244 noTestsProblem :: TargetSelector -> TargetProblem TestProblem
 245 noTestsProblem = CustomTargetProblem . TargetProblemNoTests
 246
 247 notTestProblem :: PackageId -> ComponentName -> TargetProblem TestProblem
 248 notTestProblem pkgid name = CustomTargetProblem $ TargetProblemComponentNotTest pkgid name
 249
 250 isSubComponentProblem
 251   :: PackageId
 252   -> ComponentName
 253   -> SubComponentTarget
 254   -> TargetProblem TestProblem
 255 isSubComponentProblem pkgid name subcomponent =
 256   CustomTargetProblem $
 257     TargetProblemIsSubComponent pkgid name subcomponent
 258
 259 reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a
 260 reportTargetProblems verbosity failWhenNoTestSuites problems =
 261   case (failWhenNoTestSuites, problems) of
 262     (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) ->
 263       dieWithException verbosity $ ReportTargetProblems problemsMessage
 264     (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do
 265       notice verbosity (renderAllowedNoTestsProblem selector)
 266       System.Exit.exitSuccess
 267     (_, _) -> dieWithException verbosity $ ReportTargetProblems problemsMessage
 268   where
 269     problemsMessage = unlines . map renderTestTargetProblem $ problems
 270
 271 -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't
 272 --   @die@ when the target problem is 'TargetProblemNoTests'.
 273 --   Instead, we display a notice saying that no tests have run and
 274 --   indicate how this behaviour was enabled.
 275 renderAllowedNoTestsProblem :: TargetSelector -> String
 276 renderAllowedNoTestsProblem selector =
 277   "No tests to run for " ++ renderTargetSelector selector
 278
 279 renderTestTargetProblem :: TestTargetProblem -> String
 280 renderTestTargetProblem (TargetProblemNoTargets targetSelector) =
 281   case targetSelectorFilter targetSelector of
 282     Just kind
 283       | kind /= TestKind ->
 284           "The test command is for running test suites, but the target '"
 285             ++ showTargetSelector targetSelector
 286             ++ "' refers to "
 287             ++ renderTargetSelector targetSelector
 288             ++ "."
 289             ++ "\n"
 290             ++ show targetSelector
 291     _ -> renderTargetProblemNoTargets "test" targetSelector
 292 renderTestTargetProblem problem =
 293   renderTargetProblem "test" renderTestProblem problem
 294
 295 renderTestProblem :: TestProblem -> String
 296 renderTestProblem (TargetProblemNoTests targetSelector) =
 297   "Cannot run tests for the target '"
 298     ++ showTargetSelector targetSelector
 299     ++ "' which refers to "
 300     ++ renderTargetSelector targetSelector
 301     ++ " because "
 302     ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
 303     ++ " not contain any test suites."
 304 renderTestProblem (TargetProblemComponentNotTest pkgid cname) =
 305   "The test command is for running test suites, but the target '"
 306     ++ showTargetSelector targetSelector
 307     ++ "' refers to "
 308     ++ renderTargetSelector targetSelector
 309     ++ " from the package "
 310     ++ prettyShow pkgid
 311     ++ "."
 312   where
 313     targetSelector = TargetComponent pkgid cname WholeComponent
 314 renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
 315   "The test command can only run test suites as a whole, "
 316     ++ "not files or modules within them, but the target '"
 317     ++ showTargetSelector targetSelector
 318     ++ "' refers to "
 319     ++ renderTargetSelector targetSelector
 320     ++ "."
 321   where
 322     targetSelector = TargetComponent pkgid cname subtarget