cabal-validate/src/Cli.hs

   1 -- | Parse CLI arguments and resolve defaults from the environment.
   2 module Cli
   3   ( Opts (..)
   4   , parseOpts
   5   , HackageTests (..)
   6   , Compiler (..)
   7   , VersionParseException (..)
   8   , Verbosity (..)
   9   , whenVerbose
  10   )
  11 where
  12
  13 import Control.Applicative (Alternative (many, (<|>)), (<**>))
  14 import Control.Exception (Exception (displayException), throw)
  15 import Control.Monad (forM_, when)
  16 import Data.Data (Typeable)
  17 import Data.Maybe (listToMaybe)
  18 import qualified Data.Text as T
  19 import qualified Data.Text.Lazy as T (toStrict)
  20 import qualified Data.Text.Lazy.Encoding as T (decodeUtf8)
  21 import Data.Version (Version, parseVersion)
  22 import GHC.Conc (getNumCapabilities)
  23 import Options.Applicative
  24   ( FlagFields
  25   , Mod
  26   , Parser
  27   , ParserInfo
  28   , auto
  29   , execParser
  30   , flag
  31   , flag'
  32   , fullDesc
  33   , help
  34   , helper
  35   , hidden
  36   , info
  37   , long
  38   , maybeReader
  39   , option
  40   , progDesc
  41   , short
  42   , strOption
  43   , switch
  44   , value
  45   )
  46 import qualified Options.Applicative as Opt
  47 import System.Directory (getCurrentDirectory)
  48 import System.Exit (exitSuccess)
  49 import System.Info (arch, os)
  50 import System.Process.Typed (proc, readProcessStdout_)
  51 import Text.ParserCombinators.ReadP (readP_to_S)
  52
  53 import ClockUtil (AbsoluteTime, getAbsoluteTime)
  54 import Step (Step (..), displayStep, parseStep)
  55
  56 -- | Command-line options, resolved with context from the environment.
  57 data Opts = Opts
  58   { verbosity :: Verbosity
  59   -- ^ Whether to display build and test output.
  60   , jobs :: Int
  61   -- ^ How many jobs to use when running tests.
  62   --
  63   -- Defaults to the number of physical cores.
  64   , cwd :: FilePath
  65   -- ^ Current working directory when @cabal-validate@ was started.
  66   , startTime :: AbsoluteTime
  67   -- ^ System time when @cabal-validate@ was started.
  68   --
  69   -- Used to determine the total test duration so far.
  70   , compiler :: Compiler
  71   -- ^ Compiler to build Cabal with.
  72   --
  73   -- Defaults to @ghc@.
  74   , extraCompilers :: [FilePath]
  75   -- ^ Extra compilers to run @cabal-testsuite@ with.
  76   , cabal :: FilePath
  77   -- ^ @cabal-install@ to build Cabal with.
  78   --
  79   -- Defaults to @cabal@.
  80   , hackageTests :: HackageTests
  81   -- ^ Whether to run tests on Hackage data, and if so how much.
  82   --
  83   -- Defaults to `NoHackageTests`.
  84   , archPath :: FilePath
  85   -- ^ The path for this system's architecture within the build directory.
  86   --
  87   -- Like @x86_64-windows@ or @aarch64-osx@ or @arm-linux@.
  88   , projectFile :: FilePath
  89   -- ^ Path to the @cabal.project@ file to use for running tests.
  90   , tastyArgs :: [String]
  91   -- ^ Extra arguments to pass to @tasty@ test suites.
  92   --
  93   -- This defaults to @--hide-successes@ (which cannot yet be changed) and
  94   -- includes the @--pattern@ argument if one is given.
  95   , targets :: [String]
  96   -- ^ Targets to build.
  97   , steps :: [Step]
  98   -- ^ Steps to run.
  99   }
 100   deriving (Show)
 101
 102 -- | Whether to run tests on Hackage data, and if so how much.
 103 data HackageTests
 104   = -- | Run tests on complete Hackage data.
 105     CompleteHackageTests
 106   | -- | Run tests on partial Hackage data.
 107     PartialHackageTests
 108   | -- | Do not run tests on Hackage data.
 109     NoHackageTests
 110   deriving (Show)
 111
 112 -- | A compiler executable and version number.
 113 data Compiler = Compiler
 114   { compilerExecutable :: FilePath
 115   -- ^ The compiler's executable.
 116   , compilerVersion :: Version
 117   -- ^ The compiler's version number.
 118   }
 119   deriving (Show)
 120
 121 -- | A verbosity level, for log output.
 122 data Verbosity
 123   = Quiet
 124   | Info
 125   | Verbose
 126   deriving (Show, Eq, Ord)
 127
 128 -- | Run an action only if the `verbosity` is `Verbose` or higher.
 129 whenVerbose :: Applicative f => Opts -> f () -> f ()
 130 whenVerbose opts action = when (verbosity opts >= Verbose) action
 131
 132 -- | An `Exception` thrown when parsing @--numeric-version@ output from a compiler.
 133 data VersionParseException = VersionParseException
 134   { versionInput :: String
 135   -- ^ The string we attempted to parse.
 136   , versionExecutable :: FilePath
 137   -- ^ The compiler which produced the string.
 138   }
 139   deriving (Typeable, Show)
 140
 141 instance Exception VersionParseException where
 142   displayException exception =
 143     "Failed to parse `"
 144       <> versionExecutable exception
 145       <> " --numeric-version` output: "
 146       <> show (versionInput exception)
 147
 148 -- | Runs @ghc --numeric-version@ for the given executable to construct a
 149 -- `Compiler`.
 150 makeCompiler :: FilePath -> IO Compiler
 151 makeCompiler executable = do
 152   stdout <-
 153     readProcessStdout_ $
 154       proc executable ["--numeric-version"]
 155   let version = T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout
 156       parsedVersions = readP_to_S parseVersion version
 157       -- Who needs error messages? Those aren't in the API.
 158       maybeParsedVersion =
 159         listToMaybe
 160           [ parsed
 161           | (parsed, []) <- parsedVersions
 162           ]
 163       parsedVersion = case maybeParsedVersion of
 164         Just parsedVersion' -> parsedVersion'
 165         Nothing ->
 166           throw
 167             VersionParseException
 168               { versionInput = version
 169               , versionExecutable = executable
 170               }
 171
 172   pure
 173     Compiler
 174       { compilerExecutable = executable
 175       , compilerVersion = parsedVersion
 176       }
 177
 178 -- | Resolve options and default values from the environment.
 179 --
 180 -- This makes the `Opts` type much nicer to deal with than `RawOpts`.
 181 resolveOpts :: RawOpts -> IO Opts
 182 resolveOpts opts = do
 183   let optionals :: Bool -> [a] -> [a]
 184       optionals True items = items
 185       optionals False _ = []
 186
 187       optional :: Bool -> a -> [a]
 188       optional keep item = optionals keep [item]
 189
 190       steps' =
 191         if not (null (rawSteps opts))
 192           then rawSteps opts
 193           else
 194             concat
 195               [ [Build]
 196               , optional (rawDoctest opts) Doctest
 197               , optional (rawRunLibTests opts) LibTests
 198               , optional (rawRunLibSuite opts) LibSuite
 199               , optional (rawRunLibSuite opts && not (null (rawExtraCompilers opts))) LibSuiteExtras
 200               , optional (rawRunCliTests opts && not (rawLibOnly opts)) CliTests
 201               , optional (rawRunCliSuite opts && not (rawLibOnly opts)) CliSuite
 202               , optionals (rawSolverBenchmarks opts) [SolverBenchmarksTests, SolverBenchmarksRun]
 203               ]
 204
 205       targets' =
 206         concat
 207           [
 208             [ "Cabal"
 209             , "Cabal-hooks"
 210             , "cabal-testsuite"
 211             , "Cabal-tests"
 212             , "Cabal-QuickCheck"
 213             , "Cabal-tree-diff"
 214             , "Cabal-described"
 215             ]
 216           , optionals
 217               (not (rawLibOnly opts))
 218               [ "cabal-install"
 219               , "cabal-install-solver"
 220               , "cabal-benchmarks"
 221               ]
 222           , optionals
 223               (rawSolverBenchmarks opts)
 224               [ "solver-benchmarks"
 225               , "solver-benchmarks:tests"
 226               ]
 227           ]
 228
 229       archPath' =
 230         let osPath =
 231               case os of
 232                 "darwin" -> "osx"
 233                 "linux" -> "linux"
 234                 "mingw32" -> "windows"
 235                 _ -> os -- TODO: Warning?
 236          in arch <> "-" <> osPath
 237
 238       projectFile' =
 239         if rawLibOnly opts
 240           then "cabal.validate-libonly.project"
 241           else "cabal.validate.project"
 242
 243       tastyArgs' =
 244         maybe
 245           -- If neither `--hide-successes` or `--no-hide-successes` was given, then
 246           -- only `--hide-successes` if `--quiet` is given.
 247           (optional (rawVerbosity opts <= Quiet) "--hide-successes")
 248           (\hideSuccesses -> optional hideSuccesses "--hide-successes")
 249           (rawTastyHideSuccesses opts)
 250           ++ maybe
 251             []
 252             (\tastyPattern -> ["--pattern", tastyPattern])
 253             (rawTastyPattern opts)
 254           ++ rawTastyArgs opts
 255
 256   when (rawListSteps opts) $ do
 257     -- TODO: This should probably list _all_ available steps, not just the selected ones!
 258     putStrLn "Targets:"
 259     forM_ targets' $ \target -> do
 260       putStrLn $ "  " <> target
 261     putStrLn "Steps:"
 262     forM_ steps' $ \step -> do
 263       putStrLn $ "  " <> displayStep step
 264     exitSuccess
 265
 266   startTime' <- getAbsoluteTime
 267   jobs' <- maybe getNumCapabilities pure (rawJobs opts)
 268   cwd' <- getCurrentDirectory
 269   compiler' <- makeCompiler (rawCompiler opts)
 270
 271   pure
 272     Opts
 273       { verbosity = rawVerbosity opts
 274       , jobs = jobs'
 275       , cwd = cwd'
 276       , startTime = startTime'
 277       , compiler = compiler'
 278       , extraCompilers = rawExtraCompilers opts
 279       , cabal = rawCabal opts
 280       , archPath = archPath'
 281       , projectFile = projectFile'
 282       , hackageTests = rawHackageTests opts
 283       , tastyArgs = tastyArgs'
 284       , targets = targets'
 285       , steps = steps'
 286       }
 287
 288 -- | Literate command-line options as supplied by the user, before resolving
 289 -- defaults and other values from the environment.
 290 data RawOpts = RawOpts
 291   { rawVerbosity :: Verbosity
 292   , rawJobs :: Maybe Int
 293   , rawCompiler :: FilePath
 294   , rawCabal :: FilePath
 295   , rawExtraCompilers :: [FilePath]
 296   , rawTastyPattern :: Maybe String
 297   , rawTastyArgs :: [String]
 298   , rawTastyHideSuccesses :: Maybe Bool
 299   , rawDoctest :: Bool
 300   , rawSteps :: [Step]
 301   , rawListSteps :: Bool
 302   , rawLibOnly :: Bool
 303   , rawRunLibTests :: Bool
 304   , rawRunCliTests :: Bool
 305   , rawRunLibSuite :: Bool
 306   , rawRunCliSuite :: Bool
 307   , rawSolverBenchmarks :: Bool
 308   , rawHackageTests :: HackageTests
 309   }
 310   deriving (Show)
 311
 312 -- | `Parser` for `RawOpts`.
 313 --
 314 -- See: `fullRawOptsParser`
 315 rawOptsParser :: Parser RawOpts
 316 rawOptsParser =
 317   RawOpts
 318     <$> ( flag'
 319             Verbose
 320             ( short 'v'
 321                 <> long "verbose"
 322                 <> help "Always display build and test output"
 323             )
 324             <|> flag
 325               Info
 326               Quiet
 327               ( short 'q'
 328                   <> long "quiet"
 329                   <> help "Silence build and test output"
 330               )
 331         )
 332     <*> option
 333       (Just <$> auto)
 334       ( short 'j'
 335           <> long "jobs"
 336           <> help "Passed to `cabal build --jobs`"
 337           <> value Nothing
 338       )
 339     <*> strOption
 340       ( short 'w'
 341           <> long "with-compiler"
 342           <> help "Build Cabal with the given compiler instead of `ghc`"
 343           <> value "ghc"
 344       )
 345     <*> strOption
 346       ( long "with-cabal"
 347           <> help "Test the given `cabal-install` (the `cabal` on your `$PATH` is used for builds)"
 348           <> value "cabal"
 349       )
 350     <*> many
 351       ( strOption
 352           ( long "extra-hc"
 353               <> help "Extra compilers to run the test suites against"
 354           )
 355       )
 356     <*> option
 357       (Just <$> Opt.str)
 358       ( short 'p'
 359           <> long "pattern"
 360           <> help "Pattern to filter tests by"
 361           <> value Nothing
 362       )
 363     <*> many
 364       ( strOption
 365           ( long "tasty-arg"
 366               <> help "Extra arguments to pass to Tasty test suites"
 367           )
 368       )
 369     <*> maybeBoolOption
 370       "hide-successes"
 371       ( help "Do not print tests that passed successfully"
 372       )
 373     <*> boolOption
 374       False
 375       "doctest"
 376       ( help "Run doctest on the `Cabal` library"
 377       )
 378     <*> many
 379       ( option
 380           (maybeReader parseStep)
 381           ( short 's'
 382               <> long "step"
 383               <> help "Run only a specific step (can be specified multiple times)"
 384           )
 385       )
 386     <*> switch
 387       ( long "list-steps"
 388           <> help "List the available steps and exit"
 389       )
 390     <*> ( flag'
 391             True
 392             ( long "lib-only"
 393                 <> help "Test only `Cabal` (the library)"
 394             )
 395             <|> flag
 396               False
 397               False
 398               ( long "cli"
 399                   <> help "Test `cabal-install` (the executable) in addition to `Cabal` (the library)"
 400               )
 401         )
 402     <*> boolOption
 403       True
 404       "run-lib-tests"
 405       ( help "Run tests for the `Cabal` library"
 406       )
 407     <*> boolOption
 408       True
 409       "run-cli-tests"
 410       ( help "Run client tests for the `cabal-install` executable"
 411       )
 412     <*> boolOption
 413       False
 414       "run-lib-suite"
 415       ( help "Run `cabal-testsuite` with the `Cabal` library"
 416       )
 417     <*> boolOption
 418       False
 419       "run-cli-suite"
 420       ( help "Run `cabal-testsuite` with the `cabal-install` executable"
 421       )
 422     <*> boolOption
 423       False
 424       "solver-benchmarks"
 425       ( help "Build and trial run `solver-benchmarks`"
 426       )
 427     <*> ( flag'
 428             CompleteHackageTests
 429             ( long "complete-hackage-tests"
 430                 <> help "Run `hackage-tests` on complete Hackage data"
 431             )
 432             <|> flag
 433               NoHackageTests
 434               PartialHackageTests
 435               ( long "partial-hackage-tests"
 436                   <> help "Run `hackage-tests` on parts of Hackage data"
 437               )
 438         )
 439
 440 -- | Parse a boolean switch with separate names for the true and false options.
 441 boolOption' :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool
 442 boolOption' defaultValue trueName falseName modifiers =
 443   flag' True (modifiers <> long trueName)
 444     <|> flag defaultValue False (modifiers <> hidden <> long falseName)
 445
 446 -- | Parse a boolean switch with a @--no-*@ flag for setting the option to false.
 447 boolOption :: Bool -> String -> Mod FlagFields Bool -> Parser Bool
 448 boolOption defaultValue trueName =
 449   boolOption' defaultValue trueName ("no-" <> trueName)
 450
 451 -- | Like `boolOption`, but can tell if an option was passed or not.
 452 maybeBoolOption :: String -> Mod FlagFields (Maybe Bool) -> Parser (Maybe Bool)
 453 maybeBoolOption trueName modifiers =
 454   flag' (Just True) (modifiers <> long trueName)
 455     <|> flag Nothing (Just False) (modifiers <> hidden <> long ("no-" <> trueName))
 456
 457 -- | Full `Parser` for `RawOpts`, which includes a @--help@ argument and
 458 -- information about the program.
 459 fullRawOptsParser :: ParserInfo RawOpts
 460 fullRawOptsParser =
 461   info
 462     (rawOptsParser <**> helper)
 463     ( fullDesc
 464         <> progDesc "Test suite runner for `Cabal` and `cabal-install` developers"
 465     )
 466
 467 -- | Parse command-line arguments and resolve defaults from the environment,
 468 -- producing `Opts`.
 469 parseOpts :: IO Opts
 470 parseOpts = execParser fullRawOptsParser >>= resolveOpts