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