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