From 582a5c747b27f659602af77fab353de2f44dbc00 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Thu, 5 Sep 2024 16:48:38 -0700 Subject: [PATCH 01/12] Convert `validate.sh` to `cabal-validate` Closes #10317. A Haskell script will be easier to maintain and expand than the existing Bash script. This also adds a `--pattern PATTERN` option which lets you filter tests across all test suites. --- Makefile | 6 +- cabal-validate/cabal-validate.cabal | 39 ++ cabal-validate/main/Main.hs | 954 ++++++++++++++++++++++++++++ project-cabal/pkgs/tests.config | 1 + validate.sh | 555 +--------------- 5 files changed, 999 insertions(+), 556 deletions(-) create mode 100644 cabal-validate/cabal-validate.cabal create mode 100644 cabal-validate/main/Main.hs diff --git a/Makefile b/Makefile index 0912773d368..fd33c4aca7b 100644 --- a/Makefile +++ b/Makefile @@ -29,16 +29,16 @@ init: ## Set up git hooks and ignored revisions .PHONY: style style: ## Run the code styler - @fourmolu -q -i Cabal Cabal-syntax cabal-install + @fourmolu -q -i Cabal Cabal-syntax cabal-install cabal-validate .PHONY: style-modified style-modified: ## Run the code styler on modified files - @git ls-files --modified Cabal Cabal-syntax cabal-install \ + @git ls-files --modified Cabal Cabal-syntax cabal-install cabal-validate \ | grep '.hs$$' | xargs -P $(PROCS) -I {} fourmolu -q -i {} .PHONY: style-commit style-commit: ## Run the code styler on the previous commit - @git diff --name-only HEAD $(COMMIT) Cabal Cabal-syntax cabal-install \ + @git diff --name-only HEAD $(COMMIT) Cabal Cabal-syntax cabal-install cabal-validate \ | grep '.hs$$' | xargs -P $(PROCS) -I {} fourmolu -q -i {} # source generation: SPDX diff --git a/cabal-validate/cabal-validate.cabal b/cabal-validate/cabal-validate.cabal new file mode 100644 index 00000000000..938c4aadde8 --- /dev/null +++ b/cabal-validate/cabal-validate.cabal @@ -0,0 +1,39 @@ +cabal-version: 3.0 +name: cabal-validate +version: 1.0.0 +copyright: 2024-2024, Cabal Development Team (see AUTHORS file) +license: BSD-3-Clause +author: Cabal Development Team +synopsis: An internal tool for building and testing the Cabal package manager +build-type: Simple + +common warnings + ghc-options: -Wall + +executable cabal-validate + import: warnings + default-language: Haskell2010 + default-extensions: + OverloadedStrings + , TypeApplications + ghc-options: -O -threaded -rtsopts -with-rtsopts=-N + + if impl(ghc <9.6) + -- Pattern exhaustiveness checker is not as good, misses a case. + ghc-options: -Wno-incomplete-patterns + + main-is: Main.hs + hs-source-dirs: main + + build-depends: + base >=4 && <5 + , ansi-terminal >=1 && <2 + , bytestring >=0.11 && <1 + , containers >=0.6 && <1 + , directory >=1.0 && <2 + , filepath >=1 && <2 + , optparse-applicative >=0.18 && <1 + , terminal-size >=0.3 && <1 + , text >=2 && <3 + , time >=1 && <2 + , typed-process >=0.2 && <1 diff --git a/cabal-validate/main/Main.hs b/cabal-validate/main/Main.hs new file mode 100644 index 00000000000..9da91cc9a87 --- /dev/null +++ b/cabal-validate/main/Main.hs @@ -0,0 +1,954 @@ +module Main where + +import Control.Applicative (Alternative (many, (<|>)), (<**>)) +import Control.Exception (Exception (displayException), catch, throw, throwIO) +import Control.Monad (forM_, unless, when) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString +import Data.Data (Typeable) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (listToMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as T (toStrict) +import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) +import Data.Time.Clock (DiffTime, secondsToDiffTime) +import Data.Time.Clock.System (getSystemTime, systemToTAITime) +import Data.Time.Clock.TAI (AbsoluteTime, diffAbsoluteTime) +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Version (Version, makeVersion, parseVersion, showVersion) +import GHC.Conc (getNumCapabilities) +import Options.Applicative + ( FlagFields + , Mod + , Parser + , ParserInfo + , auto + , execParser + , flag + , flag' + , fullDesc + , help + , helper + , hidden + , info + , long + , maybeReader + , option + , progDesc + , short + , strOption + , switch + , value + ) +import qualified Options.Applicative as Opt +import System.Console.ANSI + ( Color (Blue, Cyan, Green, Red) + , ColorIntensity (Vivid) + , ConsoleIntensity (BoldIntensity) + , ConsoleLayer (Foreground) + , SGR (Reset, SetColor, SetConsoleIntensity) + , setSGRCode + ) +import qualified System.Console.Terminal.Size as Terminal +import System.Directory (getCurrentDirectory, withCurrentDirectory) +import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitFailure, exitSuccess) +import System.FilePath (()) +import System.Info (arch, os) +import System.Process.Typed (ExitCodeException (..), proc, readProcess, readProcessStdout_, runProcess) +import Text.ParserCombinators.ReadP (readP_to_S) + +tShow :: Show a => a -> Text +tShow = T.pack . show + +tSetSGRCode :: [SGR] -> Text +tSetSGRCode = T.pack . setSGRCode + +decodeStrip :: ByteString -> Text +decodeStrip = T.strip . T.toStrict . T.decodeUtf8 + +-- | Command-line options, resolved with context from the environment. +data ResolvedOpts = ResolvedOpts + { verbose :: Bool + , jobs :: Int + , cwd :: FilePath + , startTime :: AbsoluteTime + , compiler :: Compiler + , extraCompilers :: [FilePath] + , cabal :: FilePath + , hackageTests :: HackageTests + , archPath :: FilePath + , projectFile :: FilePath + , tastyArgs :: [String] + , targets :: [String] + , steps :: [Step] + } + deriving (Show) + +data Compiler = Compiler + { compilerExecutable :: FilePath + , compilerVersion :: Version + } + deriving (Show) + +data VersionParseException = VersionParseException + { versionInput :: String + , versionExecutable :: FilePath + } + deriving (Typeable, Show) + +instance Exception VersionParseException where + displayException exception = + "Failed to parse `" + <> versionExecutable exception + <> " --numeric-version` output: " + <> show (versionInput exception) + +makeCompiler :: FilePath -> IO Compiler +makeCompiler executable = do + stdout <- + readProcessStdout_ $ + proc executable ["--numeric-version"] + let version = T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout + parsedVersions = readP_to_S parseVersion version + -- Who needs error messages? Those aren't in the API. + maybeParsedVersion = + listToMaybe + [ parsed + | (parsed, []) <- parsedVersions + ] + parsedVersion = case maybeParsedVersion of + Just parsedVersion' -> parsedVersion' + Nothing -> + throw + VersionParseException + { versionInput = version + , versionExecutable = executable + } + + pure + Compiler + { compilerExecutable = executable + , compilerVersion = parsedVersion + } + +baseHc :: ResolvedOpts -> FilePath +baseHc opts = "ghc-" <> showVersion (compilerVersion $ compiler opts) + +baseBuildDir :: ResolvedOpts -> FilePath +baseBuildDir opts = "dist-newstyle-validate-" <> baseHc opts + +buildDir :: ResolvedOpts -> FilePath +buildDir opts = + cwd opts + baseBuildDir opts + "build" + archPath opts + baseHc opts + +jobsArgs :: ResolvedOpts -> [String] +jobsArgs opts = ["--num-threads", show $ jobs opts] + +cabalArgs :: ResolvedOpts -> [String] +cabalArgs opts = + [ "--jobs=" <> show (jobs opts) + , "--with-compiler=" <> compilerExecutable (compiler opts) + , "--builddir=" <> baseBuildDir opts + , "--project-file=" <> projectFile opts + ] + +cabalTestsuiteBuildDir :: ResolvedOpts -> FilePath +cabalTestsuiteBuildDir opts = + buildDir opts + "cabal-testsuite-3" + +cabalNewBuildArgs :: ResolvedOpts -> [String] +cabalNewBuildArgs opts = "build" : cabalArgs opts + +cabalListBinArgs :: ResolvedOpts -> [String] +cabalListBinArgs opts = "list-bin" : cabalArgs opts + +cabalListBin :: ResolvedOpts -> String -> IO FilePath +cabalListBin opts target = do + let args = cabalListBinArgs opts ++ [target] + stdout <- + readProcessStdout_ $ + proc (cabal opts) args + + pure (T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout) + +rtsArgs :: ResolvedOpts -> [String] +rtsArgs opts = + case archPath opts of + "x86_64-windows" -> + -- See: https://github.com/haskell/cabal/issues/9571 + if compilerVersion (compiler opts) > makeVersion [9, 0, 2] + then ["+RTS", "--io-manager=native", "-RTS"] + else [] + _ -> [] + +resolveOpts :: Opts -> IO ResolvedOpts +resolveOpts opts = do + let optionals :: Bool -> [a] -> [a] + optionals True items = items + optionals False _ = [] + + optional :: Bool -> a -> [a] + optional keep item = optionals keep [item] + + steps' = + if not (null (rawSteps opts)) + then rawSteps opts + else + concat + [ + [ PrintConfig + , PrintToolVersions + , Build + ] + , optional (rawDoctest opts) Doctest + , optional (rawRunLibTests opts) LibTests + , optional (rawRunLibSuite opts) LibSuite + , optional (rawRunLibSuite opts && not (null (rawExtraCompilers opts))) LibSuiteExtras + , optional (rawRunCliTests opts && not (rawLibOnly opts)) CliTests + , optional (rawRunCliSuite opts && not (rawLibOnly opts)) CliSuite + , optionals (rawSolverBenchmarks opts) [SolverBenchmarksTests, SolverBenchmarksRun] + , [TimeSummary] + ] + + targets' = + concat + [ + [ "Cabal" + , "Cabal-hooks" + , "cabal-testsuite" + , "Cabal-tests" + , "Cabal-QuickCheck" + , "Cabal-tree-diff" + , "Cabal-described" + ] + , optionals + (CliTests `elem` steps') + [ "cabal-install" + , "cabal-install-solver" + , "cabal-benchmarks" + ] + , optional (rawSolverBenchmarks opts) "solver-benchmarks" + ] + + archPath' = + let osPath = + case os of + "darwin" -> "osx" + "linux" -> "linux" + "mingw32" -> "windows" + _ -> os -- TODO: Warning? + in arch <> "-" <> osPath + + projectFile' = + if rawLibOnly opts + then "cabal.validate-libonly.project" + else "cabal.validate.project" + + tastyArgs' = + "--hide-successes" + : case rawTastyPattern opts of + Just tastyPattern -> ["--pattern", tastyPattern] + Nothing -> [] + + when (rawListSteps opts) $ do + -- TODO: This should probably list _all_ available steps, not just the selected ones! + putStrLn "Targets:" + forM_ targets' $ \target -> do + putStrLn $ " " <> target + putStrLn "Steps:" + forM_ steps' $ \step -> do + putStrLn $ " " <> displayStep step + exitSuccess + + startTime' <- getAbsoluteTime + jobs' <- maybe getNumCapabilities pure (rawJobs opts) + cwd' <- getCurrentDirectory + compiler' <- makeCompiler (rawCompiler opts) + + pure + ResolvedOpts + { verbose = rawVerbose opts + , jobs = jobs' + , cwd = cwd' + , startTime = startTime' + , compiler = compiler' + , extraCompilers = rawExtraCompilers opts + , cabal = rawCabal opts + , archPath = archPath' + , projectFile = projectFile' + , hackageTests = rawHackageTests opts + , tastyArgs = tastyArgs' + , targets = targets' + , steps = steps' + } + +-- | Command-line options. +data Opts = Opts + { rawVerbose :: Bool + , rawJobs :: Maybe Int + , rawCompiler :: FilePath + , rawCabal :: FilePath + , rawExtraCompilers :: [FilePath] + , rawTastyPattern :: Maybe String + , rawDoctest :: Bool + , rawSteps :: [Step] + , rawListSteps :: Bool + , rawLibOnly :: Bool + , rawRunLibTests :: Bool + , rawRunCliTests :: Bool + , rawRunLibSuite :: Bool + , rawRunCliSuite :: Bool + , rawSolverBenchmarks :: Bool + , rawHackageTests :: HackageTests + } + deriving (Show) + +optsParser :: Parser Opts +optsParser = + Opts + <$> ( flag' + True + ( short 'v' + <> long "verbose" + <> help "Always display build and test output" + ) + <|> flag + False + False + ( short 'q' + <> long "quiet" + <> help "Silence build and test output" + ) + ) + <*> option + (Just <$> auto) + ( short 'j' + <> long "jobs" + <> help "Passed to `cabal build --jobs`" + <> value Nothing + ) + <*> strOption + ( short 'w' + <> long "with-compiler" + <> help "Build Cabal with the given compiler instead of `ghc`" + <> value "ghc" + ) + <*> strOption + ( long "with-cabal" + <> help "Test the given `cabal-install` (the `cabal` on your `$PATH` is used for builds)" + <> value "cabal" + ) + <*> many + ( strOption + ( long "extra-hc" + <> help "Extra compilers to run the test suites against" + ) + ) + <*> option + (Just <$> Opt.str) + ( short 'p' + <> long "pattern" + <> help "Pattern to filter tests by" + <> value Nothing + ) + <*> boolOption + False + "doctest" + ( help "Run doctest on the `Cabal` library" + ) + <*> many + ( option + (maybeReader parseStep) + ( short 's' + <> long "step" + <> help "Run only a specific step (can be specified multiple times)" + ) + ) + <*> switch + ( long "list-steps" + <> help "List the available steps and exit" + ) + <*> ( flag' + True + ( long "lib-only" + <> help "Test only `Cabal` (the library)" + ) + <|> flag + False + False + ( long "cli" + <> help "Test `cabal-install` (the executable) in addition to `Cabal` (the library)" + ) + ) + <*> boolOption + True + "run-lib-tests" + ( help "Run tests for the `Cabal` library" + ) + <*> boolOption + True + "run-cli-tests" + ( help "Run client tests for the `cabal-install` executable" + ) + <*> boolOption + False + "run-lib-suite" + ( help "Run `cabal-testsuite` with the `Cabal` library" + ) + <*> boolOption + False + "run-cli-suite" + ( help "Run `cabal-testsuite` with the `cabal-install` executable" + ) + <*> boolOption + False + "solver-benchmarks" + ( help "Build and trial run `solver-benchmarks`" + ) + <*> ( flag' + CompleteHackageTests + ( long "complete-hackage-tests" + <> help "Run `hackage-tests` on complete Hackage data" + ) + <|> flag + NoHackageTests + PartialHackageTests + ( long "partial-hackage-tests" + <> help "Run `hackage-tests` on parts of Hackage data" + ) + ) + +-- | Parse a boolean switch with separate names for the true and false options. +boolOption' :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool +boolOption' defaultValue trueName falseName modifiers = + flag' True (modifiers <> long trueName) + <|> flag defaultValue False (modifiers <> hidden <> long falseName) + +-- | Parse a boolean switch with a `--no-*` flag for setting the option to false. +boolOption :: Bool -> String -> Mod FlagFields Bool -> Parser Bool +boolOption defaultValue trueName = + boolOption' defaultValue trueName ("no-" <> trueName) + +fullOptsParser :: ParserInfo Opts +fullOptsParser = + info + (optsParser <**> helper) + ( fullDesc + <> progDesc "Test suite runner for `Cabal` and `cabal-install` developers" + ) + +data HackageTests + = CompleteHackageTests + | PartialHackageTests + | NoHackageTests + deriving (Show) + +data Step + = PrintConfig + | PrintToolVersions + | Build + | Doctest + | LibTests + | LibSuite + | LibSuiteExtras + | CliTests + | CliSuite + | SolverBenchmarksTests + | SolverBenchmarksRun + | TimeSummary + deriving (Eq, Enum, Bounded, Show) + +displayStep :: Step -> String +displayStep step = + case step of + PrintConfig -> "print-config" + PrintToolVersions -> "print-tool-versions" + Build -> "build" + Doctest -> "doctest" + LibTests -> "lib-tests" + LibSuite -> "lib-suite" + LibSuiteExtras -> "lib-suite-extras" + CliTests -> "cli-tests" + CliSuite -> "cli-suite" + SolverBenchmarksTests -> "solver-benchmarks-tests" + SolverBenchmarksRun -> "solver-benchmarks-run" + TimeSummary -> "time-summary" + +nameToStep :: Map String Step +nameToStep = + Map.fromList + [ (displayStep step, step) + | step <- [minBound .. maxBound] + ] + +parseStep :: String -> Maybe Step +parseStep step = Map.lookup step nameToStep + +runStep :: ResolvedOpts -> Step -> IO () +runStep opts step = do + let title = displayStep step + printHeader title + let action = case step of + PrintConfig -> printConfig opts + PrintToolVersions -> printToolVersions opts + Build -> build opts + Doctest -> doctest opts + LibTests -> libTests opts + LibSuite -> libSuite opts + LibSuiteExtras -> libSuiteExtras opts + CliSuite -> cliSuite opts + CliTests -> cliTests opts + SolverBenchmarksTests -> solverBenchmarksTests opts + SolverBenchmarksRun -> solverBenchmarksRun opts + TimeSummary -> timeSummary opts + withTiming opts title action + T.putStrLn "" + +getTerminalWidth :: IO Int +getTerminalWidth = maybe 80 Terminal.width <$> Terminal.size @Int + +printHeader :: String -> IO () +printHeader title = do + columns <- getTerminalWidth + let left = 3 + right = columns - length title - left - 2 + header = + setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + <> replicate left '═' + <> " " + <> title + <> " " + <> replicate right '═' + <> setSGRCode [Reset] + putStrLn header + +withTiming :: ResolvedOpts -> String -> IO a -> IO a +withTiming opts title action = do + startTime' <- getAbsoluteTime + + result <- + (Right <$> action) + `catch` (\exception -> pure (Left (exception :: ExitCodeException))) + + endTime <- getAbsoluteTime + + let duration = diffAbsoluteTime endTime startTime' + totalDuration = diffAbsoluteTime endTime (startTime opts) + + case result of + Right inner -> do + putStrLn $ + setSGRCode [SetColor Foreground Vivid Green] + <> title + <> " finished after " + <> formatDiffTime duration + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + + pure inner + Left _procFailed -> do + putStrLn $ + setSGRCode [SetColor Foreground Vivid Red] + <> title + <> " failed after " + <> formatDiffTime duration + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + + -- TODO: `--keep-going` mode. + exitFailure + +-- TODO: Shell escaping +displayCommand :: String -> [String] -> String +displayCommand command args = command <> " " <> unwords args + +timedCabalBin :: ResolvedOpts -> String -> String -> [String] -> IO () +timedCabalBin opts package component args = do + command <- cabalListBin opts (package <> ":" <> component) + timedWithCwd + opts + package + command + args + +timedWithCwd :: ResolvedOpts -> FilePath -> String -> [String] -> IO () +timedWithCwd opts cdPath command args = + withCurrentDirectory cdPath (timed opts command args) + +timed :: ResolvedOpts -> String -> [String] -> IO () +timed opts command args = do + let prettyCommand = displayCommand command args + process = proc command args + + startTime' <- getAbsoluteTime + + -- TODO: Replace `$HOME` or `opts.cwd` for brevity? + putStrLn $ + setSGRCode [SetColor Foreground Vivid Blue] + <> "$ " + <> prettyCommand + <> setSGRCode [Reset] + + (exitCode, rawStdout, rawStderr) <- + if verbose opts + then do + exitCode <- runProcess process + pure (exitCode, ByteString.empty, ByteString.empty) + else readProcess process + + endTime <- getAbsoluteTime + + let duration = diffAbsoluteTime endTime startTime' + totalDuration = diffAbsoluteTime endTime (startTime opts) + + output = decodeStrip rawStdout <> "\n" <> decodeStrip rawStderr + linesLimit = 50 + outputLines = T.lines output + hiddenLines = length outputLines - linesLimit + tailLines = drop hiddenLines outputLines + + case exitCode of + ExitSuccess -> do + unless (verbose opts) $ do + if hiddenLines <= 0 + then T.putStrLn output + else + T.putStrLn $ + "(" + <> tShow hiddenLines + <> " lines hidden, use `--verbose` to show)\n" + <> "...\n" + <> T.unlines tailLines + + putStrLn $ + setSGRCode [SetColor Foreground Vivid Green] + <> "Finished after " + <> formatDiffTime duration + <> ": " + <> prettyCommand + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + ExitFailure exitCode' -> do + unless (verbose opts) $ do + T.putStrLn output + + putStrLn $ + setSGRCode [SetColor Foreground Vivid Red] + <> "Failed with exit code " + <> show exitCode' + <> " after " + <> formatDiffTime duration + <> ": " + <> prettyCommand + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + + throwIO + ExitCodeException + { eceExitCode = exitCode + , eceProcessConfig = process + , eceStdout = rawStdout + , eceStderr = rawStderr + } + +getAbsoluteTime :: IO AbsoluteTime +getAbsoluteTime = systemToTAITime <$> getSystemTime + +formatDiffTime :: DiffTime -> String +formatDiffTime delta = + let minute = secondsToDiffTime 60 + hour = 60 * minute + in if delta >= hour + then formatTime defaultTimeLocale "%h:%02M:%02ES" delta + else + if delta >= minute + then formatTime defaultTimeLocale "%m:%2ES" delta + else formatTime defaultTimeLocale "%2Ess" delta + +main :: IO () +main = do + opts <- execParser fullOptsParser + resolvedOpts <- resolveOpts opts + mainInner resolvedOpts + +mainInner :: ResolvedOpts -> IO () +mainInner opts = + forM_ (steps opts) $ \step -> do + runStep opts step + +printConfig :: ResolvedOpts -> IO () +printConfig opts = do + putStrLn $ + "compiler: " + <> compilerExecutable (compiler opts) + <> "\ncabal-install: " + <> cabal opts + <> "\njobs: " + <> show (jobs opts) + <> "\nsteps: " + <> unwords (map displayStep (steps opts)) + <> "\nHackage tests: " + <> show (hackageTests opts) + <> "\nverbose: " + <> show (verbose opts) + <> "\nextra compilers: " + <> unwords (extraCompilers opts) + <> "\nextra RTS options: " + <> unwords (rtsArgs opts) + +printToolVersions :: ResolvedOpts -> IO () +printToolVersions opts = do + timed opts (compilerExecutable (compiler opts)) ["--version"] + timed opts (cabal opts) ["--version"] + + forM_ (extraCompilers opts) $ \compiler' -> do + timed opts compiler' ["--version"] + +build :: ResolvedOpts -> IO () +build opts = do + printHeader "build (dry run)" + timed + opts + (cabal opts) + ( cabalNewBuildArgs opts + ++ targets opts + ++ ["--dry-run"] + ) + + printHeader "build (full build plan; cached and to-be-built dependencies)" + timed + opts + "jq" + [ "-r" + , -- TODO: Maybe use `cabal-plan`? It's a heavy dependency though... + ".\"install-plan\" | map(.\"pkg-name\" + \"-\" + .\"pkg-version\" + \" \" + .\"component-name\") | join(\"\n\")" + , baseBuildDir opts "cache" "plan.json" + ] + + printHeader "build (actual build)" + timed + opts + (cabal opts) + (cabalNewBuildArgs opts ++ targets opts) + +doctest :: ResolvedOpts -> IO () +doctest opts = do + timed + opts + "cabal-env" + [ "--name" + , "doctest-cabal" + , "--transitive" + , "QuickCheck" + ] + + timed + opts + "cabal-env" + [ "--name" + , "doctest-cabal" + , "array" + , "bytestring" + , "containers" + , "deepseq" + , "directory" + , "filepath" + , "pretty" + , "process" + , "time" + , "binary" + , "unix" + , "text" + , "parsec" + , "mtl" + ] + + timed + opts + "doctest" + [ "-package-env=doctest-Cabal" + , "--fast" + , "Cabal/Distribution" + , "Cabal/Language" + ] + +libTests :: ResolvedOpts -> IO () +libTests opts = do + let runCabalTests' suite extraArgs = + timedCabalBin + opts + "Cabal-tests" + ("test:" <> suite) + ( tastyArgs opts + ++ jobsArgs opts + ++ extraArgs + ) + + runCabalTests suite = runCabalTests' suite [] + + runCabalTests' "unit-tests" ["--with-ghc=" <> compilerExecutable (compiler opts)] + runCabalTests "check-tests" + runCabalTests "parser-tests" + runCabalTests "rpmvercmp" + runCabalTests "no-thunks-test" + + runHackageTests opts + +runHackageTests :: ResolvedOpts -> IO () +runHackageTests opts + | NoHackageTests <- hackageTests opts = pure () + | otherwise = do + command <- cabalListBin opts "Cabal-tests:test:hackage-tests" + + let + -- See #10284 for why this value is pinned. + hackageTestsIndexState = "--index-state=2024-08-25" + + hackageTest args = + timedWithCwd + opts + "Cabal-tests" + command + (args ++ [hackageTestsIndexState]) + + hackageTest ["read-fields"] + + case hackageTests opts of + CompleteHackageTests -> do + hackageTest ["parsec"] + hackageTest ["roundtrip"] + PartialHackageTests -> do + hackageTest ["parsec", "d"] + hackageTest ["roundtrip", "k"] + +libSuiteWith :: ResolvedOpts -> FilePath -> [String] -> IO () +libSuiteWith opts ghc extraArgs = + timedCabalBin + opts + "cabal-testsuite" + "exe:cabal-tests" + ( [ "--builddir=" <> cabalTestsuiteBuildDir opts + , "--with-ghc=" <> ghc + , -- This test suite doesn't support `--jobs` _or_ `--num-threads`! + "-j" <> show (jobs opts) + ] + ++ tastyArgs opts + ++ extraArgs + ) + +libSuite :: ResolvedOpts -> IO () +libSuite opts = libSuiteWith opts (compilerExecutable (compiler opts)) (rtsArgs opts) + +libSuiteExtras :: ResolvedOpts -> IO () +libSuiteExtras opts = forM_ (extraCompilers opts) $ \compiler' -> + libSuiteWith opts compiler' [] + +cliTests :: ResolvedOpts -> IO () +cliTests opts = do + -- These are sorted in asc time used, quicker tests first. + timedCabalBin + opts + "cabal-install" + "test:long-tests" + ( jobsArgs opts + ++ tastyArgs opts + ) + + -- This doesn't work in parallel either. + timedCabalBin + opts + "cabal-install" + "test:unit-tests" + ( ["--num-threads", "1"] + ++ tastyArgs opts + ) + + -- Only single job, otherwise we fail with "Heap exhausted" + timedCabalBin + opts + "cabal-install" + "test:mem-use-tests" + ( ["--num-threads", "1"] + ++ tastyArgs opts + ) + + -- This test-suite doesn't like concurrency + timedCabalBin + opts + "cabal-install" + "test:integration-tests2" + ( [ "--num-threads" + , "1" + , "--with-ghc=" <> compilerExecutable (compiler opts) + ] + ++ tastyArgs opts + ) + +cliSuite :: ResolvedOpts -> IO () +cliSuite opts = do + cabal' <- cabalListBin opts "cabal-install:exe:cabal" + + timedCabalBin + opts + "cabal-testsuite" + "exe:cabal-tests" + ( [ "--builddir=" <> cabalTestsuiteBuildDir opts + , "--with-cabal=" <> cabal' + , "--with-ghc=" <> compilerExecutable (compiler opts) + , "--intree-cabal-lib=" <> cwd opts + , "--test-tmp=" <> cwd opts "testdb" + , -- This test suite doesn't support `--jobs` _or_ `--num-threads`! + "-j" + , show (jobs opts) + ] + ++ tastyArgs opts + ++ rtsArgs opts + ) + +solverBenchmarksTests :: ResolvedOpts -> IO () +solverBenchmarksTests opts = do + command <- cabalListBin opts "solver-benchmarks:test:unit-tests" + + timedWithCwd + opts + "Cabal" + command + [] + +solverBenchmarksRun :: ResolvedOpts -> IO () +solverBenchmarksRun opts = do + command <- cabalListBin opts "solver-benchmarks:exe:hackage-benchmark" + cabal' <- cabalListBin opts "cabal-install:exe:cabal" + + timedWithCwd + opts + "Cabal" + command + [ "--cabal1=" <> cabal opts + , "--cabal2=" <> cabal' + , "--trials=5" + , "--packages=Chart-diagrams" + , "--print-trials" + ] + +timeSummary :: ResolvedOpts -> IO () +timeSummary opts = do + endTime <- getAbsoluteTime + let totalDuration = diffAbsoluteTime endTime (startTime opts) + putStrLn $ + setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + <> "!!! Validation completed in " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] diff --git a/project-cabal/pkgs/tests.config b/project-cabal/pkgs/tests.config index a9cec9c596f..75fe4af5ad7 100644 --- a/project-cabal/pkgs/tests.config +++ b/project-cabal/pkgs/tests.config @@ -2,3 +2,4 @@ packages: Cabal-QuickCheck , Cabal-tests , Cabal-tree-diff + , cabal-validate diff --git a/validate.sh b/validate.sh index b22e033f86e..b887b724e8f 100755 --- a/validate.sh +++ b/validate.sh @@ -1,554 +1,3 @@ -#!/usr/bin/env bash -# shellcheck disable=SC2086 +#!/usr/bin/env sh -# default config -####################################################################### - -# We use the default ghc in PATH as default -# Use the ghc-x.y.z trigger several errors in windows: -# * It triggers the max path length issue: -# See https://github.com/haskell/cabal/issues/6271#issuecomment-1065102255 -# * It triggers a `createProcess: does not exist` error in units tests -# See https://github.com/haskell/cabal/issues/8049 -HC=ghc -CABAL=cabal -JOBS="" -LIBTESTS=true -CLITESTS=true -CABALSUITETESTS=true -LIBONLY=false -DEPSONLY=false -DOCTEST=false -BENCHMARKS=false -VERBOSE=false -HACKAGETESTSALL=false - -TARGETS="" -STEPS="" -EXTRAHCS="" - -LISTSTEPS=false - -# Help -####################################################################### - -show_usage() { -cat <&1 - else - "$@" > "$OUTPUT" 2>&1 - fi - # echo "MOCK" > "$OUTPUT" - RET=$? - - end_time=$(date +%s) - duration=$((end_time - start_time)) - tduration=$((end_time - JOB_START_TIME)) - - if [ $RET -eq 0 ]; then - if ! $VERBOSE; then - # if output is relatively short, show everything - if [ "$(wc -l < "$OUTPUT")" -le 50 ]; then - cat "$OUTPUT" - else - echo "..." - tail -n 20 "$OUTPUT" - fi - - rm -f "$OUTPUT" - fi - - green "<<< $PRETTYCMD" "($duration/$tduration sec)" - - # bottom-margin - echo "" - else - if ! $VERBOSE; then - cat "$OUTPUT" - fi - - red "<<< $PRETTYCMD" "($duration/$tduration sec, $RET)" - red "<<< $*" "($duration/$tduration sec, $RET)" - rm -f "$OUTPUT" - exit 1 - fi -} - -print_header() { - TITLE=$1 - TITLEPAT="$(echo "$TITLE"|sed 's:.:=:g')" - cyan "===X========================================================================== $(date +%T) ===" \ - | sed "s#X$TITLEPAT=# $TITLE #" - -} - -# getopt -####################################################################### - -while [ $# -gt 0 ]; do - arg=$1 - case $arg in - --help) - show_usage - exit - ;; - -j|--jobs) - JOBS="$2" - shift - shift - ;; - --lib-only) - LIBONLY=true - shift - ;; - --cli) - LIBONLY=false - shift - ;; - --run-lib-tests) - LIBTESTS=true - shift - ;; - --no-run-lib-tests) - LIBTESTS=false - shift - ;; - --run-cli-tests) - CLITESTS=true - shift - ;; - --no-run-cli-tests) - CLITESTS=false - shift - ;; - --run-lib-suite) - LIBSUITE=true - shift - ;; - --no-run-lib-suite) - LIBSUITE=false - shift - ;; - --run-cli-suite) - CLISUITE=true - shift - ;; - --no-run-cli-suite) - CLISUITE=false - shift - ;; - -w|--with-compiler) - HC=$2 - shift - shift - ;; - --with-cabal) - CABAL=$2 - shift - shift - ;; - --extra-hc) - EXTRAHCS="$EXTRAHCS $2" - shift - shift - ;; - --doctest) - DOCTEST=true - shift - ;; - --no-doctest) - DOCTEST=false - shift - ;; - --solver-benchmarks) - BENCHMARKS=true - shift - ;; - --no-solver-benchmarks) - BENCHMARKS=false - shift - ;; - --complete-hackage-tests) - HACKAGETESTSALL=true - shift - ;; - --partial-hackage-tests) - HACKAGETESTSALL=false - shift - ;; - -v|--verbose) - VERBOSE=true - shift - ;; - -q|--quiet) - VERBOSE=false - shift - ;; - -s|--step) - STEPS="$STEPS $2" - shift - shift - ;; - --list-steps) - LISTSTEPS=true - shift - ;; - *) - echo "Unknown option $arg" - exit 1 - esac -done - -# calculate steps and build targets -####################################################################### - -# If there are no explicit steps given calculate them -if $LIBONLY; then - CLITESTS=false - CLISUITE=false - BENCHMARKS=false -fi - -if [ -z "$STEPS" ]; then - STEPS="print-config print-tool-versions" - STEPS="$STEPS build" - if $DOCTEST; then STEPS="$STEPS doctest"; fi - if $LIBTESTS; then STEPS="$STEPS lib-tests"; fi - if $LIBSUITE; then STEPS="$STEPS lib-suite"; fi - if $LIBSUITE && [ -n "$EXTRAHCS" ]; - then STEPS="$STEPS lib-suite-extras"; fi - if $CLITESTS; then STEPS="$STEPS cli-tests"; fi - if $CLISUITE; then STEPS="$STEPS cli-suite"; fi - if $BENCHMARKS; then STEPS="$STEPS solver-benchmarks-tests solver-benchmarks-run"; fi - STEPS="$STEPS time-summary" -fi - -TARGETS="Cabal Cabal-hooks cabal-testsuite Cabal-tests Cabal-QuickCheck Cabal-tree-diff Cabal-described" -if ! $LIBONLY; then TARGETS="$TARGETS cabal-install cabal-install-solver cabal-benchmarks"; fi -if $BENCHMARKS; then TARGETS="$TARGETS solver-benchmarks"; fi - -if $LISTSTEPS; then - echo "Targets: $TARGETS" - echo "Steps: $STEPS" - exit -fi - -# Adjust runtime configuration -####################################################################### - -if [ -z "$JOBS" ]; then - if command -v nproc >/dev/null; then - JOBS=$(nproc) - else - echo "Warning: \`nproc\` not found, setting \`--jobs\` to default of 4." - JOBS=4 - fi -fi - -TESTSUITEJOBS="-j$JOBS" -JOBS="-j$JOBS" - -# assume compiler is GHC -RUNHASKELL=$(echo "$HC" | sed -E 's/ghc(-[0-9.]*)$/runghc\1/') - -ARCH=$(uname -m) - -case "$ARCH" in - arm64) - ARCH=aarch64 - ;; - x86_64) - ARCH=x86_64 - ;; - *) - echo "Warning: Unknown architecture '$ARCH'" - ;; -esac - -OS=$(uname) - -case "$OS" in - MINGW64*) - ARCH="$ARCH-windows" - ;; - Linux) - ARCH="$ARCH-linux" - ;; - Darwin) - ARCH="$ARCH-osx" - ;; - *) - echo "Warning: Unknown operating system '$OS'" - ARCH="$ARCH-$OS" - ;; -esac - -if $LIBONLY; then - PROJECTFILE=cabal.validate-libonly.project -else - PROJECTFILE=cabal.validate.project -fi - -BASEHC=ghc-$($HC --numeric-version) -BUILDDIR=dist-newstyle-validate-$BASEHC -CABAL_TESTSUITE_BDIR="$(pwd)/$BUILDDIR/build/$ARCH/$BASEHC/cabal-testsuite-3" - -CABALNEWBUILD="${CABAL} build $JOBS -w $HC --builddir=$BUILDDIR --project-file=$PROJECTFILE" -CABALLISTBIN="${CABAL} list-bin --builddir=$BUILDDIR --project-file=$PROJECTFILE" - -# See https://github.com/haskell/cabal/issues/9571 for why we set this for Windows -RTSOPTS="$([ $ARCH = "x86_64-windows" ] && [ "$($HC --numeric-version)" != "9.0.2" ] && [ "$(echo -e "$(ghc --numeric-version)\n9.0.2" | sort -V | head -n1)" = "9.0.2" ] && echo "+RTS --io-manager=native" || echo "")" - -# header -####################################################################### - -step_print_config() { -print_header print-config - -cat < Date: Fri, 6 Sep 2024 18:16:47 -0700 Subject: [PATCH 02/12] Split `cabal-validate` into modules This disentangles the utility boilerplate from the validation logic, making the `Main.hs` module much easier to read and modify. --- cabal-validate/cabal-validate.cabal | 26 +- cabal-validate/main/Main.hs | 954 ---------------------------- cabal-validate/src/Cli.hs | 381 +++++++++++ cabal-validate/src/ClockUtil.hs | 26 + cabal-validate/src/Main.hs | 379 +++++++++++ cabal-validate/src/OutputUtil.hs | 76 +++ cabal-validate/src/ProcessUtil.hs | 116 ++++ cabal-validate/src/Step.hs | 50 ++ 8 files changed, 1045 insertions(+), 963 deletions(-) delete mode 100644 cabal-validate/main/Main.hs create mode 100644 cabal-validate/src/Cli.hs create mode 100644 cabal-validate/src/ClockUtil.hs create mode 100644 cabal-validate/src/Main.hs create mode 100644 cabal-validate/src/OutputUtil.hs create mode 100644 cabal-validate/src/ProcessUtil.hs create mode 100644 cabal-validate/src/Step.hs diff --git a/cabal-validate/cabal-validate.cabal b/cabal-validate/cabal-validate.cabal index 938c4aadde8..ccd6762c6eb 100644 --- a/cabal-validate/cabal-validate.cabal +++ b/cabal-validate/cabal-validate.cabal @@ -7,26 +7,34 @@ author: Cabal Development Team synopsis: An internal tool for building and testing the Cabal package manager build-type: Simple -common warnings +common common ghc-options: -Wall -executable cabal-validate - import: warnings + if impl(ghc <9.6) + -- Pattern exhaustiveness checker is not as good, misses a case. + ghc-options: -Wno-incomplete-patterns + default-language: Haskell2010 default-extensions: OverloadedStrings , TypeApplications - ghc-options: -O -threaded -rtsopts -with-rtsopts=-N - if impl(ghc <9.6) - -- Pattern exhaustiveness checker is not as good, misses a case. - ghc-options: -Wno-incomplete-patterns +executable cabal-validate + import: common + ghc-options: -O -threaded -rtsopts -with-rtsopts=-N main-is: Main.hs - hs-source-dirs: main + hs-source-dirs: src + + other-modules: + , Cli + , ClockUtil + , OutputUtil + , ProcessUtil + , Step build-depends: - base >=4 && <5 + , base >=4 && <5 , ansi-terminal >=1 && <2 , bytestring >=0.11 && <1 , containers >=0.6 && <1 diff --git a/cabal-validate/main/Main.hs b/cabal-validate/main/Main.hs deleted file mode 100644 index 9da91cc9a87..00000000000 --- a/cabal-validate/main/Main.hs +++ /dev/null @@ -1,954 +0,0 @@ -module Main where - -import Control.Applicative (Alternative (many, (<|>)), (<**>)) -import Control.Exception (Exception (displayException), catch, throw, throwIO) -import Control.Monad (forM_, unless, when) -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as ByteString -import Data.Data (Typeable) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (listToMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Lazy as T (toStrict) -import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) -import Data.Time.Clock (DiffTime, secondsToDiffTime) -import Data.Time.Clock.System (getSystemTime, systemToTAITime) -import Data.Time.Clock.TAI (AbsoluteTime, diffAbsoluteTime) -import Data.Time.Format (defaultTimeLocale, formatTime) -import Data.Version (Version, makeVersion, parseVersion, showVersion) -import GHC.Conc (getNumCapabilities) -import Options.Applicative - ( FlagFields - , Mod - , Parser - , ParserInfo - , auto - , execParser - , flag - , flag' - , fullDesc - , help - , helper - , hidden - , info - , long - , maybeReader - , option - , progDesc - , short - , strOption - , switch - , value - ) -import qualified Options.Applicative as Opt -import System.Console.ANSI - ( Color (Blue, Cyan, Green, Red) - , ColorIntensity (Vivid) - , ConsoleIntensity (BoldIntensity) - , ConsoleLayer (Foreground) - , SGR (Reset, SetColor, SetConsoleIntensity) - , setSGRCode - ) -import qualified System.Console.Terminal.Size as Terminal -import System.Directory (getCurrentDirectory, withCurrentDirectory) -import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitFailure, exitSuccess) -import System.FilePath (()) -import System.Info (arch, os) -import System.Process.Typed (ExitCodeException (..), proc, readProcess, readProcessStdout_, runProcess) -import Text.ParserCombinators.ReadP (readP_to_S) - -tShow :: Show a => a -> Text -tShow = T.pack . show - -tSetSGRCode :: [SGR] -> Text -tSetSGRCode = T.pack . setSGRCode - -decodeStrip :: ByteString -> Text -decodeStrip = T.strip . T.toStrict . T.decodeUtf8 - --- | Command-line options, resolved with context from the environment. -data ResolvedOpts = ResolvedOpts - { verbose :: Bool - , jobs :: Int - , cwd :: FilePath - , startTime :: AbsoluteTime - , compiler :: Compiler - , extraCompilers :: [FilePath] - , cabal :: FilePath - , hackageTests :: HackageTests - , archPath :: FilePath - , projectFile :: FilePath - , tastyArgs :: [String] - , targets :: [String] - , steps :: [Step] - } - deriving (Show) - -data Compiler = Compiler - { compilerExecutable :: FilePath - , compilerVersion :: Version - } - deriving (Show) - -data VersionParseException = VersionParseException - { versionInput :: String - , versionExecutable :: FilePath - } - deriving (Typeable, Show) - -instance Exception VersionParseException where - displayException exception = - "Failed to parse `" - <> versionExecutable exception - <> " --numeric-version` output: " - <> show (versionInput exception) - -makeCompiler :: FilePath -> IO Compiler -makeCompiler executable = do - stdout <- - readProcessStdout_ $ - proc executable ["--numeric-version"] - let version = T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout - parsedVersions = readP_to_S parseVersion version - -- Who needs error messages? Those aren't in the API. - maybeParsedVersion = - listToMaybe - [ parsed - | (parsed, []) <- parsedVersions - ] - parsedVersion = case maybeParsedVersion of - Just parsedVersion' -> parsedVersion' - Nothing -> - throw - VersionParseException - { versionInput = version - , versionExecutable = executable - } - - pure - Compiler - { compilerExecutable = executable - , compilerVersion = parsedVersion - } - -baseHc :: ResolvedOpts -> FilePath -baseHc opts = "ghc-" <> showVersion (compilerVersion $ compiler opts) - -baseBuildDir :: ResolvedOpts -> FilePath -baseBuildDir opts = "dist-newstyle-validate-" <> baseHc opts - -buildDir :: ResolvedOpts -> FilePath -buildDir opts = - cwd opts - baseBuildDir opts - "build" - archPath opts - baseHc opts - -jobsArgs :: ResolvedOpts -> [String] -jobsArgs opts = ["--num-threads", show $ jobs opts] - -cabalArgs :: ResolvedOpts -> [String] -cabalArgs opts = - [ "--jobs=" <> show (jobs opts) - , "--with-compiler=" <> compilerExecutable (compiler opts) - , "--builddir=" <> baseBuildDir opts - , "--project-file=" <> projectFile opts - ] - -cabalTestsuiteBuildDir :: ResolvedOpts -> FilePath -cabalTestsuiteBuildDir opts = - buildDir opts - "cabal-testsuite-3" - -cabalNewBuildArgs :: ResolvedOpts -> [String] -cabalNewBuildArgs opts = "build" : cabalArgs opts - -cabalListBinArgs :: ResolvedOpts -> [String] -cabalListBinArgs opts = "list-bin" : cabalArgs opts - -cabalListBin :: ResolvedOpts -> String -> IO FilePath -cabalListBin opts target = do - let args = cabalListBinArgs opts ++ [target] - stdout <- - readProcessStdout_ $ - proc (cabal opts) args - - pure (T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout) - -rtsArgs :: ResolvedOpts -> [String] -rtsArgs opts = - case archPath opts of - "x86_64-windows" -> - -- See: https://github.com/haskell/cabal/issues/9571 - if compilerVersion (compiler opts) > makeVersion [9, 0, 2] - then ["+RTS", "--io-manager=native", "-RTS"] - else [] - _ -> [] - -resolveOpts :: Opts -> IO ResolvedOpts -resolveOpts opts = do - let optionals :: Bool -> [a] -> [a] - optionals True items = items - optionals False _ = [] - - optional :: Bool -> a -> [a] - optional keep item = optionals keep [item] - - steps' = - if not (null (rawSteps opts)) - then rawSteps opts - else - concat - [ - [ PrintConfig - , PrintToolVersions - , Build - ] - , optional (rawDoctest opts) Doctest - , optional (rawRunLibTests opts) LibTests - , optional (rawRunLibSuite opts) LibSuite - , optional (rawRunLibSuite opts && not (null (rawExtraCompilers opts))) LibSuiteExtras - , optional (rawRunCliTests opts && not (rawLibOnly opts)) CliTests - , optional (rawRunCliSuite opts && not (rawLibOnly opts)) CliSuite - , optionals (rawSolverBenchmarks opts) [SolverBenchmarksTests, SolverBenchmarksRun] - , [TimeSummary] - ] - - targets' = - concat - [ - [ "Cabal" - , "Cabal-hooks" - , "cabal-testsuite" - , "Cabal-tests" - , "Cabal-QuickCheck" - , "Cabal-tree-diff" - , "Cabal-described" - ] - , optionals - (CliTests `elem` steps') - [ "cabal-install" - , "cabal-install-solver" - , "cabal-benchmarks" - ] - , optional (rawSolverBenchmarks opts) "solver-benchmarks" - ] - - archPath' = - let osPath = - case os of - "darwin" -> "osx" - "linux" -> "linux" - "mingw32" -> "windows" - _ -> os -- TODO: Warning? - in arch <> "-" <> osPath - - projectFile' = - if rawLibOnly opts - then "cabal.validate-libonly.project" - else "cabal.validate.project" - - tastyArgs' = - "--hide-successes" - : case rawTastyPattern opts of - Just tastyPattern -> ["--pattern", tastyPattern] - Nothing -> [] - - when (rawListSteps opts) $ do - -- TODO: This should probably list _all_ available steps, not just the selected ones! - putStrLn "Targets:" - forM_ targets' $ \target -> do - putStrLn $ " " <> target - putStrLn "Steps:" - forM_ steps' $ \step -> do - putStrLn $ " " <> displayStep step - exitSuccess - - startTime' <- getAbsoluteTime - jobs' <- maybe getNumCapabilities pure (rawJobs opts) - cwd' <- getCurrentDirectory - compiler' <- makeCompiler (rawCompiler opts) - - pure - ResolvedOpts - { verbose = rawVerbose opts - , jobs = jobs' - , cwd = cwd' - , startTime = startTime' - , compiler = compiler' - , extraCompilers = rawExtraCompilers opts - , cabal = rawCabal opts - , archPath = archPath' - , projectFile = projectFile' - , hackageTests = rawHackageTests opts - , tastyArgs = tastyArgs' - , targets = targets' - , steps = steps' - } - --- | Command-line options. -data Opts = Opts - { rawVerbose :: Bool - , rawJobs :: Maybe Int - , rawCompiler :: FilePath - , rawCabal :: FilePath - , rawExtraCompilers :: [FilePath] - , rawTastyPattern :: Maybe String - , rawDoctest :: Bool - , rawSteps :: [Step] - , rawListSteps :: Bool - , rawLibOnly :: Bool - , rawRunLibTests :: Bool - , rawRunCliTests :: Bool - , rawRunLibSuite :: Bool - , rawRunCliSuite :: Bool - , rawSolverBenchmarks :: Bool - , rawHackageTests :: HackageTests - } - deriving (Show) - -optsParser :: Parser Opts -optsParser = - Opts - <$> ( flag' - True - ( short 'v' - <> long "verbose" - <> help "Always display build and test output" - ) - <|> flag - False - False - ( short 'q' - <> long "quiet" - <> help "Silence build and test output" - ) - ) - <*> option - (Just <$> auto) - ( short 'j' - <> long "jobs" - <> help "Passed to `cabal build --jobs`" - <> value Nothing - ) - <*> strOption - ( short 'w' - <> long "with-compiler" - <> help "Build Cabal with the given compiler instead of `ghc`" - <> value "ghc" - ) - <*> strOption - ( long "with-cabal" - <> help "Test the given `cabal-install` (the `cabal` on your `$PATH` is used for builds)" - <> value "cabal" - ) - <*> many - ( strOption - ( long "extra-hc" - <> help "Extra compilers to run the test suites against" - ) - ) - <*> option - (Just <$> Opt.str) - ( short 'p' - <> long "pattern" - <> help "Pattern to filter tests by" - <> value Nothing - ) - <*> boolOption - False - "doctest" - ( help "Run doctest on the `Cabal` library" - ) - <*> many - ( option - (maybeReader parseStep) - ( short 's' - <> long "step" - <> help "Run only a specific step (can be specified multiple times)" - ) - ) - <*> switch - ( long "list-steps" - <> help "List the available steps and exit" - ) - <*> ( flag' - True - ( long "lib-only" - <> help "Test only `Cabal` (the library)" - ) - <|> flag - False - False - ( long "cli" - <> help "Test `cabal-install` (the executable) in addition to `Cabal` (the library)" - ) - ) - <*> boolOption - True - "run-lib-tests" - ( help "Run tests for the `Cabal` library" - ) - <*> boolOption - True - "run-cli-tests" - ( help "Run client tests for the `cabal-install` executable" - ) - <*> boolOption - False - "run-lib-suite" - ( help "Run `cabal-testsuite` with the `Cabal` library" - ) - <*> boolOption - False - "run-cli-suite" - ( help "Run `cabal-testsuite` with the `cabal-install` executable" - ) - <*> boolOption - False - "solver-benchmarks" - ( help "Build and trial run `solver-benchmarks`" - ) - <*> ( flag' - CompleteHackageTests - ( long "complete-hackage-tests" - <> help "Run `hackage-tests` on complete Hackage data" - ) - <|> flag - NoHackageTests - PartialHackageTests - ( long "partial-hackage-tests" - <> help "Run `hackage-tests` on parts of Hackage data" - ) - ) - --- | Parse a boolean switch with separate names for the true and false options. -boolOption' :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool -boolOption' defaultValue trueName falseName modifiers = - flag' True (modifiers <> long trueName) - <|> flag defaultValue False (modifiers <> hidden <> long falseName) - --- | Parse a boolean switch with a `--no-*` flag for setting the option to false. -boolOption :: Bool -> String -> Mod FlagFields Bool -> Parser Bool -boolOption defaultValue trueName = - boolOption' defaultValue trueName ("no-" <> trueName) - -fullOptsParser :: ParserInfo Opts -fullOptsParser = - info - (optsParser <**> helper) - ( fullDesc - <> progDesc "Test suite runner for `Cabal` and `cabal-install` developers" - ) - -data HackageTests - = CompleteHackageTests - | PartialHackageTests - | NoHackageTests - deriving (Show) - -data Step - = PrintConfig - | PrintToolVersions - | Build - | Doctest - | LibTests - | LibSuite - | LibSuiteExtras - | CliTests - | CliSuite - | SolverBenchmarksTests - | SolverBenchmarksRun - | TimeSummary - deriving (Eq, Enum, Bounded, Show) - -displayStep :: Step -> String -displayStep step = - case step of - PrintConfig -> "print-config" - PrintToolVersions -> "print-tool-versions" - Build -> "build" - Doctest -> "doctest" - LibTests -> "lib-tests" - LibSuite -> "lib-suite" - LibSuiteExtras -> "lib-suite-extras" - CliTests -> "cli-tests" - CliSuite -> "cli-suite" - SolverBenchmarksTests -> "solver-benchmarks-tests" - SolverBenchmarksRun -> "solver-benchmarks-run" - TimeSummary -> "time-summary" - -nameToStep :: Map String Step -nameToStep = - Map.fromList - [ (displayStep step, step) - | step <- [minBound .. maxBound] - ] - -parseStep :: String -> Maybe Step -parseStep step = Map.lookup step nameToStep - -runStep :: ResolvedOpts -> Step -> IO () -runStep opts step = do - let title = displayStep step - printHeader title - let action = case step of - PrintConfig -> printConfig opts - PrintToolVersions -> printToolVersions opts - Build -> build opts - Doctest -> doctest opts - LibTests -> libTests opts - LibSuite -> libSuite opts - LibSuiteExtras -> libSuiteExtras opts - CliSuite -> cliSuite opts - CliTests -> cliTests opts - SolverBenchmarksTests -> solverBenchmarksTests opts - SolverBenchmarksRun -> solverBenchmarksRun opts - TimeSummary -> timeSummary opts - withTiming opts title action - T.putStrLn "" - -getTerminalWidth :: IO Int -getTerminalWidth = maybe 80 Terminal.width <$> Terminal.size @Int - -printHeader :: String -> IO () -printHeader title = do - columns <- getTerminalWidth - let left = 3 - right = columns - length title - left - 2 - header = - setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] - <> replicate left '═' - <> " " - <> title - <> " " - <> replicate right '═' - <> setSGRCode [Reset] - putStrLn header - -withTiming :: ResolvedOpts -> String -> IO a -> IO a -withTiming opts title action = do - startTime' <- getAbsoluteTime - - result <- - (Right <$> action) - `catch` (\exception -> pure (Left (exception :: ExitCodeException))) - - endTime <- getAbsoluteTime - - let duration = diffAbsoluteTime endTime startTime' - totalDuration = diffAbsoluteTime endTime (startTime opts) - - case result of - Right inner -> do - putStrLn $ - setSGRCode [SetColor Foreground Vivid Green] - <> title - <> " finished after " - <> formatDiffTime duration - <> "\nTotal time so far: " - <> formatDiffTime totalDuration - <> setSGRCode [Reset] - - pure inner - Left _procFailed -> do - putStrLn $ - setSGRCode [SetColor Foreground Vivid Red] - <> title - <> " failed after " - <> formatDiffTime duration - <> "\nTotal time so far: " - <> formatDiffTime totalDuration - <> setSGRCode [Reset] - - -- TODO: `--keep-going` mode. - exitFailure - --- TODO: Shell escaping -displayCommand :: String -> [String] -> String -displayCommand command args = command <> " " <> unwords args - -timedCabalBin :: ResolvedOpts -> String -> String -> [String] -> IO () -timedCabalBin opts package component args = do - command <- cabalListBin opts (package <> ":" <> component) - timedWithCwd - opts - package - command - args - -timedWithCwd :: ResolvedOpts -> FilePath -> String -> [String] -> IO () -timedWithCwd opts cdPath command args = - withCurrentDirectory cdPath (timed opts command args) - -timed :: ResolvedOpts -> String -> [String] -> IO () -timed opts command args = do - let prettyCommand = displayCommand command args - process = proc command args - - startTime' <- getAbsoluteTime - - -- TODO: Replace `$HOME` or `opts.cwd` for brevity? - putStrLn $ - setSGRCode [SetColor Foreground Vivid Blue] - <> "$ " - <> prettyCommand - <> setSGRCode [Reset] - - (exitCode, rawStdout, rawStderr) <- - if verbose opts - then do - exitCode <- runProcess process - pure (exitCode, ByteString.empty, ByteString.empty) - else readProcess process - - endTime <- getAbsoluteTime - - let duration = diffAbsoluteTime endTime startTime' - totalDuration = diffAbsoluteTime endTime (startTime opts) - - output = decodeStrip rawStdout <> "\n" <> decodeStrip rawStderr - linesLimit = 50 - outputLines = T.lines output - hiddenLines = length outputLines - linesLimit - tailLines = drop hiddenLines outputLines - - case exitCode of - ExitSuccess -> do - unless (verbose opts) $ do - if hiddenLines <= 0 - then T.putStrLn output - else - T.putStrLn $ - "(" - <> tShow hiddenLines - <> " lines hidden, use `--verbose` to show)\n" - <> "...\n" - <> T.unlines tailLines - - putStrLn $ - setSGRCode [SetColor Foreground Vivid Green] - <> "Finished after " - <> formatDiffTime duration - <> ": " - <> prettyCommand - <> "\nTotal time so far: " - <> formatDiffTime totalDuration - <> setSGRCode [Reset] - ExitFailure exitCode' -> do - unless (verbose opts) $ do - T.putStrLn output - - putStrLn $ - setSGRCode [SetColor Foreground Vivid Red] - <> "Failed with exit code " - <> show exitCode' - <> " after " - <> formatDiffTime duration - <> ": " - <> prettyCommand - <> "\nTotal time so far: " - <> formatDiffTime totalDuration - <> setSGRCode [Reset] - - throwIO - ExitCodeException - { eceExitCode = exitCode - , eceProcessConfig = process - , eceStdout = rawStdout - , eceStderr = rawStderr - } - -getAbsoluteTime :: IO AbsoluteTime -getAbsoluteTime = systemToTAITime <$> getSystemTime - -formatDiffTime :: DiffTime -> String -formatDiffTime delta = - let minute = secondsToDiffTime 60 - hour = 60 * minute - in if delta >= hour - then formatTime defaultTimeLocale "%h:%02M:%02ES" delta - else - if delta >= minute - then formatTime defaultTimeLocale "%m:%2ES" delta - else formatTime defaultTimeLocale "%2Ess" delta - -main :: IO () -main = do - opts <- execParser fullOptsParser - resolvedOpts <- resolveOpts opts - mainInner resolvedOpts - -mainInner :: ResolvedOpts -> IO () -mainInner opts = - forM_ (steps opts) $ \step -> do - runStep opts step - -printConfig :: ResolvedOpts -> IO () -printConfig opts = do - putStrLn $ - "compiler: " - <> compilerExecutable (compiler opts) - <> "\ncabal-install: " - <> cabal opts - <> "\njobs: " - <> show (jobs opts) - <> "\nsteps: " - <> unwords (map displayStep (steps opts)) - <> "\nHackage tests: " - <> show (hackageTests opts) - <> "\nverbose: " - <> show (verbose opts) - <> "\nextra compilers: " - <> unwords (extraCompilers opts) - <> "\nextra RTS options: " - <> unwords (rtsArgs opts) - -printToolVersions :: ResolvedOpts -> IO () -printToolVersions opts = do - timed opts (compilerExecutable (compiler opts)) ["--version"] - timed opts (cabal opts) ["--version"] - - forM_ (extraCompilers opts) $ \compiler' -> do - timed opts compiler' ["--version"] - -build :: ResolvedOpts -> IO () -build opts = do - printHeader "build (dry run)" - timed - opts - (cabal opts) - ( cabalNewBuildArgs opts - ++ targets opts - ++ ["--dry-run"] - ) - - printHeader "build (full build plan; cached and to-be-built dependencies)" - timed - opts - "jq" - [ "-r" - , -- TODO: Maybe use `cabal-plan`? It's a heavy dependency though... - ".\"install-plan\" | map(.\"pkg-name\" + \"-\" + .\"pkg-version\" + \" \" + .\"component-name\") | join(\"\n\")" - , baseBuildDir opts "cache" "plan.json" - ] - - printHeader "build (actual build)" - timed - opts - (cabal opts) - (cabalNewBuildArgs opts ++ targets opts) - -doctest :: ResolvedOpts -> IO () -doctest opts = do - timed - opts - "cabal-env" - [ "--name" - , "doctest-cabal" - , "--transitive" - , "QuickCheck" - ] - - timed - opts - "cabal-env" - [ "--name" - , "doctest-cabal" - , "array" - , "bytestring" - , "containers" - , "deepseq" - , "directory" - , "filepath" - , "pretty" - , "process" - , "time" - , "binary" - , "unix" - , "text" - , "parsec" - , "mtl" - ] - - timed - opts - "doctest" - [ "-package-env=doctest-Cabal" - , "--fast" - , "Cabal/Distribution" - , "Cabal/Language" - ] - -libTests :: ResolvedOpts -> IO () -libTests opts = do - let runCabalTests' suite extraArgs = - timedCabalBin - opts - "Cabal-tests" - ("test:" <> suite) - ( tastyArgs opts - ++ jobsArgs opts - ++ extraArgs - ) - - runCabalTests suite = runCabalTests' suite [] - - runCabalTests' "unit-tests" ["--with-ghc=" <> compilerExecutable (compiler opts)] - runCabalTests "check-tests" - runCabalTests "parser-tests" - runCabalTests "rpmvercmp" - runCabalTests "no-thunks-test" - - runHackageTests opts - -runHackageTests :: ResolvedOpts -> IO () -runHackageTests opts - | NoHackageTests <- hackageTests opts = pure () - | otherwise = do - command <- cabalListBin opts "Cabal-tests:test:hackage-tests" - - let - -- See #10284 for why this value is pinned. - hackageTestsIndexState = "--index-state=2024-08-25" - - hackageTest args = - timedWithCwd - opts - "Cabal-tests" - command - (args ++ [hackageTestsIndexState]) - - hackageTest ["read-fields"] - - case hackageTests opts of - CompleteHackageTests -> do - hackageTest ["parsec"] - hackageTest ["roundtrip"] - PartialHackageTests -> do - hackageTest ["parsec", "d"] - hackageTest ["roundtrip", "k"] - -libSuiteWith :: ResolvedOpts -> FilePath -> [String] -> IO () -libSuiteWith opts ghc extraArgs = - timedCabalBin - opts - "cabal-testsuite" - "exe:cabal-tests" - ( [ "--builddir=" <> cabalTestsuiteBuildDir opts - , "--with-ghc=" <> ghc - , -- This test suite doesn't support `--jobs` _or_ `--num-threads`! - "-j" <> show (jobs opts) - ] - ++ tastyArgs opts - ++ extraArgs - ) - -libSuite :: ResolvedOpts -> IO () -libSuite opts = libSuiteWith opts (compilerExecutable (compiler opts)) (rtsArgs opts) - -libSuiteExtras :: ResolvedOpts -> IO () -libSuiteExtras opts = forM_ (extraCompilers opts) $ \compiler' -> - libSuiteWith opts compiler' [] - -cliTests :: ResolvedOpts -> IO () -cliTests opts = do - -- These are sorted in asc time used, quicker tests first. - timedCabalBin - opts - "cabal-install" - "test:long-tests" - ( jobsArgs opts - ++ tastyArgs opts - ) - - -- This doesn't work in parallel either. - timedCabalBin - opts - "cabal-install" - "test:unit-tests" - ( ["--num-threads", "1"] - ++ tastyArgs opts - ) - - -- Only single job, otherwise we fail with "Heap exhausted" - timedCabalBin - opts - "cabal-install" - "test:mem-use-tests" - ( ["--num-threads", "1"] - ++ tastyArgs opts - ) - - -- This test-suite doesn't like concurrency - timedCabalBin - opts - "cabal-install" - "test:integration-tests2" - ( [ "--num-threads" - , "1" - , "--with-ghc=" <> compilerExecutable (compiler opts) - ] - ++ tastyArgs opts - ) - -cliSuite :: ResolvedOpts -> IO () -cliSuite opts = do - cabal' <- cabalListBin opts "cabal-install:exe:cabal" - - timedCabalBin - opts - "cabal-testsuite" - "exe:cabal-tests" - ( [ "--builddir=" <> cabalTestsuiteBuildDir opts - , "--with-cabal=" <> cabal' - , "--with-ghc=" <> compilerExecutable (compiler opts) - , "--intree-cabal-lib=" <> cwd opts - , "--test-tmp=" <> cwd opts "testdb" - , -- This test suite doesn't support `--jobs` _or_ `--num-threads`! - "-j" - , show (jobs opts) - ] - ++ tastyArgs opts - ++ rtsArgs opts - ) - -solverBenchmarksTests :: ResolvedOpts -> IO () -solverBenchmarksTests opts = do - command <- cabalListBin opts "solver-benchmarks:test:unit-tests" - - timedWithCwd - opts - "Cabal" - command - [] - -solverBenchmarksRun :: ResolvedOpts -> IO () -solverBenchmarksRun opts = do - command <- cabalListBin opts "solver-benchmarks:exe:hackage-benchmark" - cabal' <- cabalListBin opts "cabal-install:exe:cabal" - - timedWithCwd - opts - "Cabal" - command - [ "--cabal1=" <> cabal opts - , "--cabal2=" <> cabal' - , "--trials=5" - , "--packages=Chart-diagrams" - , "--print-trials" - ] - -timeSummary :: ResolvedOpts -> IO () -timeSummary opts = do - endTime <- getAbsoluteTime - let totalDuration = diffAbsoluteTime endTime (startTime opts) - putStrLn $ - setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] - <> "!!! Validation completed in " - <> formatDiffTime totalDuration - <> setSGRCode [Reset] diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs new file mode 100644 index 00000000000..f82b5b6d944 --- /dev/null +++ b/cabal-validate/src/Cli.hs @@ -0,0 +1,381 @@ +module Cli + ( Opts (..) + , parseOpts + , HackageTests (..) + , Compiler (..) + , VersionParseException (..) + ) +where + +import Control.Applicative (Alternative (many, (<|>)), (<**>)) +import Control.Exception (Exception (displayException), throw) +import Control.Monad (forM_, when) +import Data.Data (Typeable) +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import qualified Data.Text.Lazy as T (toStrict) +import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) +import Data.Version (Version, parseVersion) +import GHC.Conc (getNumCapabilities) +import Options.Applicative + ( FlagFields + , Mod + , Parser + , ParserInfo + , auto + , execParser + , flag + , flag' + , fullDesc + , help + , helper + , hidden + , info + , long + , maybeReader + , option + , progDesc + , short + , strOption + , switch + , value + ) +import qualified Options.Applicative as Opt +import System.Directory (getCurrentDirectory) +import System.Exit (exitSuccess) +import System.Info (arch, os) +import System.Process.Typed (proc, readProcessStdout_) +import Text.ParserCombinators.ReadP (readP_to_S) + +import ClockUtil (AbsoluteTime, getAbsoluteTime) +import Step (Step (..), displayStep, parseStep) + +-- | Command-line options, resolved with context from the environment. +data Opts = Opts + { verbose :: Bool + , jobs :: Int + , cwd :: FilePath + , startTime :: AbsoluteTime + , compiler :: Compiler + , extraCompilers :: [FilePath] + , cabal :: FilePath + , hackageTests :: HackageTests + , archPath :: FilePath + , projectFile :: FilePath + , tastyArgs :: [String] + , targets :: [String] + , steps :: [Step] + } + deriving (Show) + +data HackageTests + = CompleteHackageTests + | PartialHackageTests + | NoHackageTests + deriving (Show) + +data Compiler = Compiler + { compilerExecutable :: FilePath + , compilerVersion :: Version + } + deriving (Show) + +data VersionParseException = VersionParseException + { versionInput :: String + , versionExecutable :: FilePath + } + deriving (Typeable, Show) + +instance Exception VersionParseException where + displayException exception = + "Failed to parse `" + <> versionExecutable exception + <> " --numeric-version` output: " + <> show (versionInput exception) + +makeCompiler :: FilePath -> IO Compiler +makeCompiler executable = do + stdout <- + readProcessStdout_ $ + proc executable ["--numeric-version"] + let version = T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout + parsedVersions = readP_to_S parseVersion version + -- Who needs error messages? Those aren't in the API. + maybeParsedVersion = + listToMaybe + [ parsed + | (parsed, []) <- parsedVersions + ] + parsedVersion = case maybeParsedVersion of + Just parsedVersion' -> parsedVersion' + Nothing -> + throw + VersionParseException + { versionInput = version + , versionExecutable = executable + } + + pure + Compiler + { compilerExecutable = executable + , compilerVersion = parsedVersion + } + +resolveOpts :: RawOpts -> IO Opts +resolveOpts opts = do + let optionals :: Bool -> [a] -> [a] + optionals True items = items + optionals False _ = [] + + optional :: Bool -> a -> [a] + optional keep item = optionals keep [item] + + steps' = + if not (null (rawSteps opts)) + then rawSteps opts + else + concat + [ + [ PrintConfig + , PrintToolVersions + , Build + ] + , optional (rawDoctest opts) Doctest + , optional (rawRunLibTests opts) LibTests + , optional (rawRunLibSuite opts) LibSuite + , optional (rawRunLibSuite opts && not (null (rawExtraCompilers opts))) LibSuiteExtras + , optional (rawRunCliTests opts && not (rawLibOnly opts)) CliTests + , optional (rawRunCliSuite opts && not (rawLibOnly opts)) CliSuite + , optionals (rawSolverBenchmarks opts) [SolverBenchmarksTests, SolverBenchmarksRun] + , [TimeSummary] + ] + + targets' = + concat + [ + [ "Cabal" + , "Cabal-hooks" + , "cabal-testsuite" + , "Cabal-tests" + , "Cabal-QuickCheck" + , "Cabal-tree-diff" + , "Cabal-described" + ] + , optionals + (CliTests `elem` steps') + [ "cabal-install" + , "cabal-install-solver" + , "cabal-benchmarks" + ] + , optional (rawSolverBenchmarks opts) "solver-benchmarks" + ] + + archPath' = + let osPath = + case os of + "darwin" -> "osx" + "linux" -> "linux" + "mingw32" -> "windows" + _ -> os -- TODO: Warning? + in arch <> "-" <> osPath + + projectFile' = + if rawLibOnly opts + then "cabal.validate-libonly.project" + else "cabal.validate.project" + + tastyArgs' = + "--hide-successes" + : case rawTastyPattern opts of + Just tastyPattern -> ["--pattern", tastyPattern] + Nothing -> [] + + when (rawListSteps opts) $ do + -- TODO: This should probably list _all_ available steps, not just the selected ones! + putStrLn "Targets:" + forM_ targets' $ \target -> do + putStrLn $ " " <> target + putStrLn "Steps:" + forM_ steps' $ \step -> do + putStrLn $ " " <> displayStep step + exitSuccess + + startTime' <- getAbsoluteTime + jobs' <- maybe getNumCapabilities pure (rawJobs opts) + cwd' <- getCurrentDirectory + compiler' <- makeCompiler (rawCompiler opts) + + pure + Opts + { verbose = rawVerbose opts + , jobs = jobs' + , cwd = cwd' + , startTime = startTime' + , compiler = compiler' + , extraCompilers = rawExtraCompilers opts + , cabal = rawCabal opts + , archPath = archPath' + , projectFile = projectFile' + , hackageTests = rawHackageTests opts + , tastyArgs = tastyArgs' + , targets = targets' + , steps = steps' + } + +-- | Command-line options. +data RawOpts = RawOpts + { rawVerbose :: Bool + , rawJobs :: Maybe Int + , rawCompiler :: FilePath + , rawCabal :: FilePath + , rawExtraCompilers :: [FilePath] + , rawTastyPattern :: Maybe String + , rawDoctest :: Bool + , rawSteps :: [Step] + , rawListSteps :: Bool + , rawLibOnly :: Bool + , rawRunLibTests :: Bool + , rawRunCliTests :: Bool + , rawRunLibSuite :: Bool + , rawRunCliSuite :: Bool + , rawSolverBenchmarks :: Bool + , rawHackageTests :: HackageTests + } + deriving (Show) + +optsParser :: Parser RawOpts +optsParser = + RawOpts + <$> ( flag' + True + ( short 'v' + <> long "verbose" + <> help "Always display build and test output" + ) + <|> flag + False + False + ( short 'q' + <> long "quiet" + <> help "Silence build and test output" + ) + ) + <*> option + (Just <$> auto) + ( short 'j' + <> long "jobs" + <> help "Passed to `cabal build --jobs`" + <> value Nothing + ) + <*> strOption + ( short 'w' + <> long "with-compiler" + <> help "Build Cabal with the given compiler instead of `ghc`" + <> value "ghc" + ) + <*> strOption + ( long "with-cabal" + <> help "Test the given `cabal-install` (the `cabal` on your `$PATH` is used for builds)" + <> value "cabal" + ) + <*> many + ( strOption + ( long "extra-hc" + <> help "Extra compilers to run the test suites against" + ) + ) + <*> option + (Just <$> Opt.str) + ( short 'p' + <> long "pattern" + <> help "Pattern to filter tests by" + <> value Nothing + ) + <*> boolOption + False + "doctest" + ( help "Run doctest on the `Cabal` library" + ) + <*> many + ( option + (maybeReader parseStep) + ( short 's' + <> long "step" + <> help "Run only a specific step (can be specified multiple times)" + ) + ) + <*> switch + ( long "list-steps" + <> help "List the available steps and exit" + ) + <*> ( flag' + True + ( long "lib-only" + <> help "Test only `Cabal` (the library)" + ) + <|> flag + False + False + ( long "cli" + <> help "Test `cabal-install` (the executable) in addition to `Cabal` (the library)" + ) + ) + <*> boolOption + True + "run-lib-tests" + ( help "Run tests for the `Cabal` library" + ) + <*> boolOption + True + "run-cli-tests" + ( help "Run client tests for the `cabal-install` executable" + ) + <*> boolOption + False + "run-lib-suite" + ( help "Run `cabal-testsuite` with the `Cabal` library" + ) + <*> boolOption + False + "run-cli-suite" + ( help "Run `cabal-testsuite` with the `cabal-install` executable" + ) + <*> boolOption + False + "solver-benchmarks" + ( help "Build and trial run `solver-benchmarks`" + ) + <*> ( flag' + CompleteHackageTests + ( long "complete-hackage-tests" + <> help "Run `hackage-tests` on complete Hackage data" + ) + <|> flag + NoHackageTests + PartialHackageTests + ( long "partial-hackage-tests" + <> help "Run `hackage-tests` on parts of Hackage data" + ) + ) + +-- | Parse a boolean switch with separate names for the true and false options. +boolOption' :: Bool -> String -> String -> Mod FlagFields Bool -> Parser Bool +boolOption' defaultValue trueName falseName modifiers = + flag' True (modifiers <> long trueName) + <|> flag defaultValue False (modifiers <> hidden <> long falseName) + +-- | Parse a boolean switch with a `--no-*` flag for setting the option to false. +boolOption :: Bool -> String -> Mod FlagFields Bool -> Parser Bool +boolOption defaultValue trueName = + boolOption' defaultValue trueName ("no-" <> trueName) + +fullOptsParser :: ParserInfo RawOpts +fullOptsParser = + info + (optsParser <**> helper) + ( fullDesc + <> progDesc "Test suite runner for `Cabal` and `cabal-install` developers" + ) + +parseOpts :: IO Opts +parseOpts = execParser fullOptsParser >>= resolveOpts diff --git a/cabal-validate/src/ClockUtil.hs b/cabal-validate/src/ClockUtil.hs new file mode 100644 index 00000000000..aba7930bd58 --- /dev/null +++ b/cabal-validate/src/ClockUtil.hs @@ -0,0 +1,26 @@ +module ClockUtil + ( DiffTime + , AbsoluteTime + , diffAbsoluteTime + , getAbsoluteTime + , formatDiffTime + ) where + +import Data.Time.Clock (DiffTime, secondsToDiffTime) +import Data.Time.Clock.System (getSystemTime, systemToTAITime) +import Data.Time.Clock.TAI (AbsoluteTime, diffAbsoluteTime) +import Data.Time.Format (defaultTimeLocale, formatTime) + +getAbsoluteTime :: IO AbsoluteTime +getAbsoluteTime = systemToTAITime <$> getSystemTime + +formatDiffTime :: DiffTime -> String +formatDiffTime delta = + let minute = secondsToDiffTime 60 + hour = 60 * minute + in if delta >= hour + then formatTime defaultTimeLocale "%h:%02M:%02ES" delta + else + if delta >= minute + then formatTime defaultTimeLocale "%m:%2ES" delta + else formatTime defaultTimeLocale "%2Ess" delta diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs new file mode 100644 index 00000000000..6cf1818e9bc --- /dev/null +++ b/cabal-validate/src/Main.hs @@ -0,0 +1,379 @@ +module Main where + +import Control.Monad (forM_) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as T (toStrict) +import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) +import Data.Version (makeVersion, showVersion) +import System.Console.ANSI + ( Color (Cyan) + , ColorIntensity (Vivid) + , ConsoleIntensity (BoldIntensity) + , ConsoleLayer (Foreground) + , SGR (Reset, SetColor, SetConsoleIntensity) + , setSGRCode + ) +import System.FilePath (()) +import System.Process.Typed (proc, readProcessStdout_) + +import Cli (Compiler (..), HackageTests (..), Opts (..), parseOpts) +import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) +import OutputUtil (printHeader, withTiming) +import ProcessUtil (timed, timedWithCwd) +import Step (Step (..), displayStep) + +main :: IO () +main = do + opts <- parseOpts + forM_ (steps opts) $ \step -> do + runStep opts step + +baseHc :: Opts -> FilePath +baseHc opts = "ghc-" <> showVersion (compilerVersion $ compiler opts) + +baseBuildDir :: Opts -> FilePath +baseBuildDir opts = "dist-newstyle-validate-" <> baseHc opts + +buildDir :: Opts -> FilePath +buildDir opts = + cwd opts + baseBuildDir opts + "build" + archPath opts + baseHc opts + +jobsArgs :: Opts -> [String] +jobsArgs opts = ["--num-threads", show $ jobs opts] + +cabalArgs :: Opts -> [String] +cabalArgs opts = + [ "--jobs=" <> show (jobs opts) + , "--with-compiler=" <> compilerExecutable (compiler opts) + , "--builddir=" <> baseBuildDir opts + , "--project-file=" <> projectFile opts + ] + +cabalTestsuiteBuildDir :: Opts -> FilePath +cabalTestsuiteBuildDir opts = + buildDir opts + "cabal-testsuite-3" + +cabalNewBuildArgs :: Opts -> [String] +cabalNewBuildArgs opts = "build" : cabalArgs opts + +cabalListBinArgs :: Opts -> [String] +cabalListBinArgs opts = "list-bin" : cabalArgs opts + +cabalListBin :: Opts -> String -> IO FilePath +cabalListBin opts target = do + let args = cabalListBinArgs opts ++ [target] + stdout <- + readProcessStdout_ $ + proc (cabal opts) args + + pure (T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout) + +rtsArgs :: Opts -> [String] +rtsArgs opts = + case archPath opts of + "x86_64-windows" -> + -- See: https://github.com/haskell/cabal/issues/9571 + if compilerVersion (compiler opts) > makeVersion [9, 0, 2] + then ["+RTS", "--io-manager=native", "-RTS"] + else [] + _ -> [] + +runStep :: Opts -> Step -> IO () +runStep opts step = do + let title = displayStep step + printHeader title + let action = case step of + PrintConfig -> printConfig opts + PrintToolVersions -> printToolVersions opts + Build -> build opts + Doctest -> doctest opts + LibTests -> libTests opts + LibSuite -> libSuite opts + LibSuiteExtras -> libSuiteExtras opts + CliSuite -> cliSuite opts + CliTests -> cliTests opts + SolverBenchmarksTests -> solverBenchmarksTests opts + SolverBenchmarksRun -> solverBenchmarksRun opts + TimeSummary -> timeSummary opts + withTiming opts title action + T.putStrLn "" + +timedCabalBin :: Opts -> String -> String -> [String] -> IO () +timedCabalBin opts package component args = do + command <- cabalListBin opts (package <> ":" <> component) + timedWithCwd + opts + package + command + args + +printConfig :: Opts -> IO () +printConfig opts = do + putStrLn $ + "compiler: " + <> compilerExecutable (compiler opts) + <> "\ncabal-install: " + <> cabal opts + <> "\njobs: " + <> show (jobs opts) + <> "\nsteps: " + <> unwords (map displayStep (steps opts)) + <> "\nHackage tests: " + <> show (hackageTests opts) + <> "\nverbose: " + <> show (verbose opts) + <> "\nextra compilers: " + <> unwords (extraCompilers opts) + <> "\nextra RTS options: " + <> unwords (rtsArgs opts) + +printToolVersions :: Opts -> IO () +printToolVersions opts = do + timed opts (compilerExecutable (compiler opts)) ["--version"] + timed opts (cabal opts) ["--version"] + + forM_ (extraCompilers opts) $ \compiler' -> do + timed opts compiler' ["--version"] + +build :: Opts -> IO () +build opts = do + printHeader "build (dry run)" + timed + opts + (cabal opts) + ( cabalNewBuildArgs opts + ++ targets opts + ++ ["--dry-run"] + ) + + printHeader "build (full build plan; cached and to-be-built dependencies)" + timed + opts + "jq" + [ "-r" + , -- TODO: Maybe use `cabal-plan`? It's a heavy dependency though... + ".\"install-plan\" | map(.\"pkg-name\" + \"-\" + .\"pkg-version\" + \" \" + .\"component-name\") | join(\"\n\")" + , baseBuildDir opts "cache" "plan.json" + ] + + printHeader "build (actual build)" + timed + opts + (cabal opts) + (cabalNewBuildArgs opts ++ targets opts) + +doctest :: Opts -> IO () +doctest opts = do + timed + opts + "cabal-env" + [ "--name" + , "doctest-cabal" + , "--transitive" + , "QuickCheck" + ] + + timed + opts + "cabal-env" + [ "--name" + , "doctest-cabal" + , "array" + , "bytestring" + , "containers" + , "deepseq" + , "directory" + , "filepath" + , "pretty" + , "process" + , "time" + , "binary" + , "unix" + , "text" + , "parsec" + , "mtl" + ] + + timed + opts + "doctest" + [ "-package-env=doctest-Cabal" + , "--fast" + , "Cabal/Distribution" + , "Cabal/Language" + ] + +libTests :: Opts -> IO () +libTests opts = do + let runCabalTests' suite extraArgs = + timedCabalBin + opts + "Cabal-tests" + ("test:" <> suite) + ( tastyArgs opts + ++ jobsArgs opts + ++ extraArgs + ) + + runCabalTests suite = runCabalTests' suite [] + + runCabalTests' "unit-tests" ["--with-ghc=" <> compilerExecutable (compiler opts)] + runCabalTests "check-tests" + runCabalTests "parser-tests" + runCabalTests "rpmvercmp" + runCabalTests "no-thunks-test" + + runHackageTests opts + +runHackageTests :: Opts -> IO () +runHackageTests opts + | NoHackageTests <- hackageTests opts = pure () + | otherwise = do + command <- cabalListBin opts "Cabal-tests:test:hackage-tests" + + let + -- See #10284 for why this value is pinned. + hackageTestsIndexState = "--index-state=2024-08-25" + + hackageTest args = + timedWithCwd + opts + "Cabal-tests" + command + (args ++ [hackageTestsIndexState]) + + hackageTest ["read-fields"] + + case hackageTests opts of + CompleteHackageTests -> do + hackageTest ["parsec"] + hackageTest ["roundtrip"] + PartialHackageTests -> do + hackageTest ["parsec", "d"] + hackageTest ["roundtrip", "k"] + +libSuiteWith :: Opts -> FilePath -> [String] -> IO () +libSuiteWith opts ghc extraArgs = + timedCabalBin + opts + "cabal-testsuite" + "exe:cabal-tests" + ( [ "--builddir=" <> cabalTestsuiteBuildDir opts + , "--with-ghc=" <> ghc + , -- This test suite doesn't support `--jobs` _or_ `--num-threads`! + "-j" <> show (jobs opts) + ] + ++ tastyArgs opts + ++ extraArgs + ) + +libSuite :: Opts -> IO () +libSuite opts = libSuiteWith opts (compilerExecutable (compiler opts)) (rtsArgs opts) + +libSuiteExtras :: Opts -> IO () +libSuiteExtras opts = forM_ (extraCompilers opts) $ \compiler' -> + libSuiteWith opts compiler' [] + +cliTests :: Opts -> IO () +cliTests opts = do + -- These are sorted in asc time used, quicker tests first. + timedCabalBin + opts + "cabal-install" + "test:long-tests" + ( jobsArgs opts + ++ tastyArgs opts + ) + + -- This doesn't work in parallel either. + timedCabalBin + opts + "cabal-install" + "test:unit-tests" + ( ["--num-threads", "1"] + ++ tastyArgs opts + ) + + -- Only single job, otherwise we fail with "Heap exhausted" + timedCabalBin + opts + "cabal-install" + "test:mem-use-tests" + ( ["--num-threads", "1"] + ++ tastyArgs opts + ) + + -- This test-suite doesn't like concurrency + timedCabalBin + opts + "cabal-install" + "test:integration-tests2" + ( [ "--num-threads" + , "1" + , "--with-ghc=" <> compilerExecutable (compiler opts) + ] + ++ tastyArgs opts + ) + +cliSuite :: Opts -> IO () +cliSuite opts = do + cabal' <- cabalListBin opts "cabal-install:exe:cabal" + + timedCabalBin + opts + "cabal-testsuite" + "exe:cabal-tests" + ( [ "--builddir=" <> cabalTestsuiteBuildDir opts + , "--with-cabal=" <> cabal' + , "--with-ghc=" <> compilerExecutable (compiler opts) + , "--intree-cabal-lib=" <> cwd opts + , "--test-tmp=" <> cwd opts "testdb" + , -- This test suite doesn't support `--jobs` _or_ `--num-threads`! + "-j" + , show (jobs opts) + ] + ++ tastyArgs opts + ++ rtsArgs opts + ) + +solverBenchmarksTests :: Opts -> IO () +solverBenchmarksTests opts = do + command <- cabalListBin opts "solver-benchmarks:test:unit-tests" + + timedWithCwd + opts + "Cabal" + command + [] + +solverBenchmarksRun :: Opts -> IO () +solverBenchmarksRun opts = do + command <- cabalListBin opts "solver-benchmarks:exe:hackage-benchmark" + cabal' <- cabalListBin opts "cabal-install:exe:cabal" + + timedWithCwd + opts + "Cabal" + command + [ "--cabal1=" <> cabal opts + , "--cabal2=" <> cabal' + , "--trials=5" + , "--packages=Chart-diagrams" + , "--print-trials" + ] + +timeSummary :: Opts -> IO () +timeSummary opts = do + endTime <- getAbsoluteTime + let totalDuration = diffAbsoluteTime endTime (startTime opts) + putStrLn $ + setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + <> "!!! Validation completed in " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] diff --git a/cabal-validate/src/OutputUtil.hs b/cabal-validate/src/OutputUtil.hs new file mode 100644 index 00000000000..28d4542f6a3 --- /dev/null +++ b/cabal-validate/src/OutputUtil.hs @@ -0,0 +1,76 @@ +module OutputUtil + ( printHeader + , withTiming + ) where + +import Control.Exception (catch) +import System.Console.ANSI + ( Color (Cyan, Green, Red) + , ColorIntensity (Vivid) + , ConsoleIntensity (BoldIntensity) + , ConsoleLayer (Foreground) + , SGR (Reset, SetColor, SetConsoleIntensity) + , setSGRCode + ) +import qualified System.Console.Terminal.Size as Terminal +import System.Process.Typed (ExitCodeException) + +import Cli (Opts (..)) +import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) +import System.Exit (exitFailure) + +getTerminalWidth :: IO Int +getTerminalWidth = maybe 80 Terminal.width <$> Terminal.size @Int + +printHeader :: String -> IO () +printHeader title = do + columns <- getTerminalWidth + let left = 3 + right = columns - length title - left - 2 + header = + setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + <> replicate left '═' + <> " " + <> title + <> " " + <> replicate right '═' + <> setSGRCode [Reset] + putStrLn header + +withTiming :: Opts -> String -> IO a -> IO a +withTiming opts title action = do + startTime' <- getAbsoluteTime + + result <- + (Right <$> action) + `catch` (\exception -> pure (Left (exception :: ExitCodeException))) + + endTime <- getAbsoluteTime + + let duration = diffAbsoluteTime endTime startTime' + totalDuration = diffAbsoluteTime endTime (startTime opts) + + case result of + Right inner -> do + putStrLn $ + setSGRCode [SetColor Foreground Vivid Green] + <> title + <> " finished after " + <> formatDiffTime duration + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + + pure inner + Left _procFailed -> do + putStrLn $ + setSGRCode [SetColor Foreground Vivid Red] + <> title + <> " failed after " + <> formatDiffTime duration + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + + -- TODO: `--keep-going` mode. + exitFailure diff --git a/cabal-validate/src/ProcessUtil.hs b/cabal-validate/src/ProcessUtil.hs new file mode 100644 index 00000000000..cefdb37d13c --- /dev/null +++ b/cabal-validate/src/ProcessUtil.hs @@ -0,0 +1,116 @@ +module ProcessUtil + ( timed + , timedWithCwd + ) where + +import Control.Exception (throwIO) +import Control.Monad (unless) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as ByteString +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as T (toStrict) +import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) +import System.Console.ANSI + ( Color (Blue, Green, Red) + , ColorIntensity (Vivid) + , ConsoleLayer (Foreground) + , SGR (Reset, SetColor) + , setSGRCode + ) +import System.Directory (withCurrentDirectory) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) +import System.Process.Typed (ExitCodeException (..), proc, readProcess, runProcess) + +import Cli (Opts (..)) +import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) + +timedWithCwd :: Opts -> FilePath -> String -> [String] -> IO () +timedWithCwd opts cdPath command args = + withCurrentDirectory cdPath (timed opts command args) + +timed :: Opts -> String -> [String] -> IO () +timed opts command args = do + let prettyCommand = displayCommand command args + process = proc command args + + startTime' <- getAbsoluteTime + + -- TODO: Replace `$HOME` or `opts.cwd` for brevity? + putStrLn $ + setSGRCode [SetColor Foreground Vivid Blue] + <> "$ " + <> prettyCommand + <> setSGRCode [Reset] + + (exitCode, rawStdout, rawStderr) <- + if verbose opts + then do + exitCode <- runProcess process + pure (exitCode, ByteString.empty, ByteString.empty) + else readProcess process + + endTime <- getAbsoluteTime + + let duration = diffAbsoluteTime endTime startTime' + totalDuration = diffAbsoluteTime endTime (startTime opts) + + output = decodeStrip rawStdout <> "\n" <> decodeStrip rawStderr + linesLimit = 50 + outputLines = T.lines output + hiddenLines = length outputLines - linesLimit + tailLines = drop hiddenLines outputLines + + case exitCode of + ExitSuccess -> do + unless (verbose opts) $ do + if hiddenLines <= 0 + then T.putStrLn output + else + T.putStrLn $ + "(" + <> T.pack (show hiddenLines) + <> " lines hidden, use `--verbose` to show)\n" + <> "...\n" + <> T.unlines tailLines + + putStrLn $ + setSGRCode [SetColor Foreground Vivid Green] + <> "Finished after " + <> formatDiffTime duration + <> ": " + <> prettyCommand + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + ExitFailure exitCode' -> do + unless (verbose opts) $ do + T.putStrLn output + + putStrLn $ + setSGRCode [SetColor Foreground Vivid Red] + <> "Failed with exit code " + <> show exitCode' + <> " after " + <> formatDiffTime duration + <> ": " + <> prettyCommand + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> setSGRCode [Reset] + + throwIO + ExitCodeException + { eceExitCode = exitCode + , eceProcessConfig = process + , eceStdout = rawStdout + , eceStderr = rawStderr + } + +decodeStrip :: ByteString -> Text +decodeStrip = T.strip . T.toStrict . T.decodeUtf8 + +-- TODO: Shell escaping +displayCommand :: String -> [String] -> String +displayCommand command args = command <> " " <> unwords args diff --git a/cabal-validate/src/Step.hs b/cabal-validate/src/Step.hs new file mode 100644 index 00000000000..34d771073dc --- /dev/null +++ b/cabal-validate/src/Step.hs @@ -0,0 +1,50 @@ +module Step + ( Step (..) + , displayStep + , nameToStep + , parseStep + ) where + +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map + +data Step + = PrintConfig + | PrintToolVersions + | Build + | Doctest + | LibTests + | LibSuite + | LibSuiteExtras + | CliTests + | CliSuite + | SolverBenchmarksTests + | SolverBenchmarksRun + | TimeSummary + deriving (Eq, Enum, Bounded, Show) + +displayStep :: Step -> String +displayStep step = + case step of + PrintConfig -> "print-config" + PrintToolVersions -> "print-tool-versions" + Build -> "build" + Doctest -> "doctest" + LibTests -> "lib-tests" + LibSuite -> "lib-suite" + LibSuiteExtras -> "lib-suite-extras" + CliTests -> "cli-tests" + CliSuite -> "cli-suite" + SolverBenchmarksTests -> "solver-benchmarks-tests" + SolverBenchmarksRun -> "solver-benchmarks-run" + TimeSummary -> "time-summary" + +nameToStep :: Map String Step +nameToStep = + Map.fromList + [ (displayStep step, step) + | step <- [minBound .. maxBound] + ] + +parseStep :: String -> Maybe Step +parseStep step = Map.lookup step nameToStep From e257591a10c42a81bdd6118847464cd469c40077 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 9 Sep 2024 13:07:22 -0700 Subject: [PATCH 03/12] cabal-validate: Add Haddock documentation + README --- cabal-validate/README.md | 23 ++++++++ cabal-validate/src/Cli.hs | 56 ++++++++++++++++++- cabal-validate/src/ClockUtil.hs | 8 +++ cabal-validate/src/Main.hs | 93 ++++++++++++++++++++++++------- cabal-validate/src/OutputUtil.hs | 22 +++++++- cabal-validate/src/ProcessUtil.hs | 31 ++++++++++- cabal-validate/src/Step.hs | 13 +++++ 7 files changed, 219 insertions(+), 27 deletions(-) create mode 100644 cabal-validate/README.md diff --git a/cabal-validate/README.md b/cabal-validate/README.md new file mode 100644 index 00000000000..5f40e9d28f1 --- /dev/null +++ b/cabal-validate/README.md @@ -0,0 +1,23 @@ +# cabal-validate + +`cabal-validate` is a script that builds and tests `Cabal` and `cabal-install`. +`cabal-validate` can be run with `validate.sh` in the repository root; +arguments passed to `validate.sh` will be forwarded to `cabal-validate`. + +Notable arguments include: + +- `-v`/`--verbose` to display build and test output in real-time, instead of + only if commands fail. +- `-s`/`--step` to run a specific step (e.g. `-s build -s lib-tests` will only + run the `build` and `lib-tests` steps). +- `-p`/`--pattern` to filter tests by a pattern. + +## Hacking on cabal-validate + +Overview of important modules: + +- `Main.hs` encodes all the commands that are run for each step. +- `Cli.hs` parses the CLI arguments and resolves default values from the + environment, like determining which steps are run by default or the `--jobs` + argument to pass to test suites. +- `Step.hs` lists the available steps. diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs index f82b5b6d944..c0988d2ead4 100644 --- a/cabal-validate/src/Cli.hs +++ b/cabal-validate/src/Cli.hs @@ -1,3 +1,5 @@ +-- | Parse CLI arguments and resolve defaults from the environment. + module Cli ( Opts (..) , parseOpts @@ -53,36 +55,74 @@ import Step (Step (..), displayStep, parseStep) -- | Command-line options, resolved with context from the environment. data Opts = Opts { verbose :: Bool + -- ^ Whether to display build and test output. , jobs :: Int + -- ^ How many jobs to use when running tests. + -- + -- Defaults to the number of physical cores. , cwd :: FilePath + -- ^ Current working directory when @cabal-validate@ was started. , startTime :: AbsoluteTime + -- ^ System time when @cabal-validate@ was started. + -- + -- Used to determine the total test duration so far. , compiler :: Compiler + -- ^ Compiler to build Cabal with. + -- + -- Defaults to @ghc@. , extraCompilers :: [FilePath] + -- ^ Extra compilers to run @cabal-testsuite@ with. , cabal :: FilePath + -- ^ @cabal-install@ to build Cabal with. + -- + -- Defaults to @cabal@. , hackageTests :: HackageTests + -- ^ Whether to run tests on Hackage data, and if so how much. + -- + -- Defaults to `NoHackageTests`. , archPath :: FilePath + -- ^ The path for this system's architecture within the build directory. + -- + -- Like @x86_64-windows@ or @aarch64-osx@ or @arm-linux@. , projectFile :: FilePath + -- ^ Path to the @cabal.project@ file to use for running tests. , tastyArgs :: [String] + -- ^ Extra arguments to pass to @tasty@ test suites. + -- + -- This defaults to @--hide-successes@ (which cannot yet be changed) and + -- includes the @--pattern@ argument if one is given. , targets :: [String] + -- ^ Targets to build. , steps :: [Step] + -- ^ Steps to run. } deriving (Show) +-- | Whether to run tests on Hackage data, and if so how much. data HackageTests = CompleteHackageTests + -- ^ Run tests on complete Hackage data. | PartialHackageTests + -- ^ Run tests on partial Hackage data. | NoHackageTests + -- ^ Do not run tests on Hackage data. deriving (Show) +-- | A compiler executable and version number. data Compiler = Compiler { compilerExecutable :: FilePath + -- ^ The compiler's executable. , compilerVersion :: Version + -- ^ The compiler's version number. } deriving (Show) +-- | An `Exception` thrown when parsing @--numeric-version@ output from a compiler. data VersionParseException = VersionParseException { versionInput :: String + -- ^ The string we attempted to parse. , versionExecutable :: FilePath + -- ^ The compiler which produced the string. } deriving (Typeable, Show) @@ -93,6 +133,8 @@ instance Exception VersionParseException where <> " --numeric-version` output: " <> show (versionInput exception) +-- | Runs @ghc --numeric-version@ for the given executable to construct a +-- `Compiler`. makeCompiler :: FilePath -> IO Compiler makeCompiler executable = do stdout <- @@ -121,6 +163,9 @@ makeCompiler executable = do , compilerVersion = parsedVersion } +-- | Resolve options and default values from the environment. +-- +-- This makes the `Opts` type much nicer to deal with than `RawOpts`. resolveOpts :: RawOpts -> IO Opts resolveOpts opts = do let optionals :: Bool -> [a] -> [a] @@ -222,7 +267,7 @@ resolveOpts opts = do , steps = steps' } --- | Command-line options. +-- | Raw command-line options. data RawOpts = RawOpts { rawVerbose :: Bool , rawJobs :: Maybe Int @@ -243,6 +288,9 @@ data RawOpts = RawOpts } deriving (Show) +-- | `Parser` for `RawOpts`. +-- +-- See: `fullOptsParser` optsParser :: Parser RawOpts optsParser = RawOpts @@ -364,11 +412,13 @@ boolOption' defaultValue trueName falseName modifiers = flag' True (modifiers <> long trueName) <|> flag defaultValue False (modifiers <> hidden <> long falseName) --- | Parse a boolean switch with a `--no-*` flag for setting the option to false. +-- | Parse a boolean switch with a @--no-*@ flag for setting the option to false. boolOption :: Bool -> String -> Mod FlagFields Bool -> Parser Bool boolOption defaultValue trueName = boolOption' defaultValue trueName ("no-" <> trueName) +-- | Full `Parser` for `RawOpts`, which includes a @--help@ argument and +-- information about the program. fullOptsParser :: ParserInfo RawOpts fullOptsParser = info @@ -377,5 +427,7 @@ fullOptsParser = <> progDesc "Test suite runner for `Cabal` and `cabal-install` developers" ) +-- | Parse command-line arguments and resolve defaults from the environment, +-- producing `Opts`. parseOpts :: IO Opts parseOpts = execParser fullOptsParser >>= resolveOpts diff --git a/cabal-validate/src/ClockUtil.hs b/cabal-validate/src/ClockUtil.hs index aba7930bd58..664175789e7 100644 --- a/cabal-validate/src/ClockUtil.hs +++ b/cabal-validate/src/ClockUtil.hs @@ -1,3 +1,5 @@ +-- | Utilities for dealing with times and durations. + module ClockUtil ( DiffTime , AbsoluteTime @@ -11,9 +13,15 @@ import Data.Time.Clock.System (getSystemTime, systemToTAITime) import Data.Time.Clock.TAI (AbsoluteTime, diffAbsoluteTime) import Data.Time.Format (defaultTimeLocale, formatTime) +-- | Get the current time as an `AbsoluteTime`. getAbsoluteTime :: IO AbsoluteTime getAbsoluteTime = systemToTAITime <$> getSystemTime +-- | Format a `DiffTime` nicely. +-- +-- Short durations are formatted like @16.34s@, durations longer than a minute +-- are formatted like @22:34.68@, durations longer than an hour are formatted +-- like @1:32:04.68@. formatDiffTime :: DiffTime -> String formatDiffTime delta = let minute = secondsToDiffTime 60 diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs index 6cf1818e9bc..c75c97baac5 100644 --- a/cabal-validate/src/Main.hs +++ b/cabal-validate/src/Main.hs @@ -1,4 +1,11 @@ -module Main where +-- | Entry-point to the @cabal-validate@ script. +-- +-- This module encodes all the commands that are run for each step in +-- `runStep`. +module Main + ( main + , runStep + ) where import Control.Monad (forM_) import qualified Data.Text as T @@ -23,18 +30,45 @@ import OutputUtil (printHeader, withTiming) import ProcessUtil (timed, timedWithCwd) import Step (Step (..), displayStep) +-- | Entry-point for @cabal-validate@. main :: IO () main = do opts <- parseOpts forM_ (steps opts) $ \step -> do runStep opts step +-- | Run a given `Step` with the given `Opts`. +runStep :: Opts -> Step -> IO () +runStep opts step = do + let title = displayStep step + printHeader title + let action = case step of + PrintConfig -> printConfig opts + PrintToolVersions -> printToolVersions opts + Build -> build opts + Doctest -> doctest opts + LibTests -> libTests opts + LibSuite -> libSuite opts + LibSuiteExtras -> libSuiteExtras opts + CliSuite -> cliSuite opts + CliTests -> cliTests opts + SolverBenchmarksTests -> solverBenchmarksTests opts + SolverBenchmarksRun -> solverBenchmarksRun opts + TimeSummary -> timeSummary opts + withTiming opts title action + T.putStrLn "" + +-- | Compiler with version number like @ghc-9.6.6@. baseHc :: Opts -> FilePath baseHc opts = "ghc-" <> showVersion (compilerVersion $ compiler opts) +-- | Base build directory for @cabal-validate@. baseBuildDir :: Opts -> FilePath baseBuildDir opts = "dist-newstyle-validate-" <> baseHc opts +-- | Absolute path to the build directory for this architecture. +-- +-- This is a path nested fairly deeply under `baseBuildDir`. buildDir :: Opts -> FilePath buildDir opts = cwd opts @@ -43,9 +77,14 @@ buildDir opts = archPath opts baseHc opts +-- | @--num-threads@ argument for test suites. +-- +-- This isn't always used because some test suites are finicky and only accept +-- @-j@. jobsArgs :: Opts -> [String] jobsArgs opts = ["--num-threads", show $ jobs opts] +-- | Default arguments for invoking @cabal@. cabalArgs :: Opts -> [String] cabalArgs opts = [ "--jobs=" <> show (jobs opts) @@ -54,17 +93,23 @@ cabalArgs opts = , "--project-file=" <> projectFile opts ] +-- | The `buildDir` for @cabal-testsuite-3@. cabalTestsuiteBuildDir :: Opts -> FilePath cabalTestsuiteBuildDir opts = buildDir opts "cabal-testsuite-3" +-- | Arguments for @cabal build@. cabalNewBuildArgs :: Opts -> [String] cabalNewBuildArgs opts = "build" : cabalArgs opts +-- | Arguments for @cabal list-bin@. +-- +-- This is used to find the binaries for various test suites. cabalListBinArgs :: Opts -> [String] cabalListBinArgs opts = "list-bin" : cabalArgs opts +-- | Get the binary for a given @cabal@ target by running @cabal list-bin@. cabalListBin :: Opts -> String -> IO FilePath cabalListBin opts target = do let args = cabalListBinArgs opts ++ [target] @@ -74,6 +119,9 @@ cabalListBin opts target = do pure (T.unpack $ T.strip $ T.toStrict $ T.decodeUtf8 stdout) +-- | Get the RTS arguments for invoking test suites. +-- +-- These seem to only be used for some of the test suites, I'm not sure why. rtsArgs :: Opts -> [String] rtsArgs opts = case archPath opts of @@ -84,26 +132,9 @@ rtsArgs opts = else [] _ -> [] -runStep :: Opts -> Step -> IO () -runStep opts step = do - let title = displayStep step - printHeader title - let action = case step of - PrintConfig -> printConfig opts - PrintToolVersions -> printToolVersions opts - Build -> build opts - Doctest -> doctest opts - LibTests -> libTests opts - LibSuite -> libSuite opts - LibSuiteExtras -> libSuiteExtras opts - CliSuite -> cliSuite opts - CliTests -> cliTests opts - SolverBenchmarksTests -> solverBenchmarksTests opts - SolverBenchmarksRun -> solverBenchmarksRun opts - TimeSummary -> timeSummary opts - withTiming opts title action - T.putStrLn "" - +-- | Run a binary built by @cabal@ and output timing information. +-- +-- This is used to run many of the test suites. timedCabalBin :: Opts -> String -> String -> [String] -> IO () timedCabalBin opts package component args = do command <- cabalListBin opts (package <> ":" <> component) @@ -113,6 +144,7 @@ timedCabalBin opts package component args = do command args +-- | Print the configuration for CI logs. printConfig :: Opts -> IO () printConfig opts = do putStrLn $ @@ -133,6 +165,7 @@ printConfig opts = do <> "\nextra RTS options: " <> unwords (rtsArgs opts) +-- | Print the versions of tools being used. printToolVersions :: Opts -> IO () printToolVersions opts = do timed opts (compilerExecutable (compiler opts)) ["--version"] @@ -141,6 +174,7 @@ printToolVersions opts = do forM_ (extraCompilers opts) $ \compiler' -> do timed opts compiler' ["--version"] +-- | Run the build step. build :: Opts -> IO () build opts = do printHeader "build (dry run)" @@ -168,6 +202,10 @@ build opts = do (cabal opts) (cabalNewBuildArgs opts ++ targets opts) +-- | Run doctests. +-- +-- This doesn't work on my machine, maybe @cabal.nix@ needs some love to +-- support @cabal-env@? doctest :: Opts -> IO () doctest opts = do timed @@ -209,6 +247,8 @@ doctest opts = do , "Cabal/Language" ] +-- | Run tests for the @Cabal@ library, and also `runHackageTests` if those are +-- enabled. libTests :: Opts -> IO () libTests opts = do let runCabalTests' suite extraArgs = @@ -231,6 +271,7 @@ libTests opts = do runHackageTests opts +-- | Run Hackage tests, if enabled. runHackageTests :: Opts -> IO () runHackageTests opts | NoHackageTests <- hackageTests opts = pure () @@ -258,6 +299,7 @@ runHackageTests opts hackageTest ["parsec", "d"] hackageTest ["roundtrip", "k"] +-- | Run @cabal-testsuite@ with the @Cabal@ library with a non-default GHC. libSuiteWith :: Opts -> FilePath -> [String] -> IO () libSuiteWith opts ghc extraArgs = timedCabalBin @@ -273,13 +315,18 @@ libSuiteWith opts ghc extraArgs = ++ extraArgs ) +-- | Run @cabal-testsuite@ with the @Cabal@ library with the default GHC. libSuite :: Opts -> IO () libSuite opts = libSuiteWith opts (compilerExecutable (compiler opts)) (rtsArgs opts) +-- | Run @cabal-testsuite@ with the @Cabal@ library with all extra GHCs. libSuiteExtras :: Opts -> IO () libSuiteExtras opts = forM_ (extraCompilers opts) $ \compiler' -> libSuiteWith opts compiler' [] +-- | Test the @cabal-install@ executable. +-- +-- These tests mostly run sequentially, so they're pretty slow as a result. cliTests :: Opts -> IO () cliTests opts = do -- These are sorted in asc time used, quicker tests first. @@ -321,6 +368,7 @@ cliTests opts = do ++ tastyArgs opts ) +-- | Run @cabal-testsuite@ with the @cabal-install@ executable. cliSuite :: Opts -> IO () cliSuite opts = do cabal' <- cabalListBin opts "cabal-install:exe:cabal" @@ -342,6 +390,7 @@ cliSuite opts = do ++ rtsArgs opts ) +-- | Run the @solver-benchmarks@ unit tests. solverBenchmarksTests :: Opts -> IO () solverBenchmarksTests opts = do command <- cabalListBin opts "solver-benchmarks:test:unit-tests" @@ -352,6 +401,7 @@ solverBenchmarksTests opts = do command [] +-- | Run the @solver-benchmarks@. solverBenchmarksRun :: Opts -> IO () solverBenchmarksRun opts = do command <- cabalListBin opts "solver-benchmarks:exe:hackage-benchmark" @@ -368,6 +418,7 @@ solverBenchmarksRun opts = do , "--print-trials" ] +-- | Print the total time taken so far. timeSummary :: Opts -> IO () timeSummary opts = do endTime <- getAbsoluteTime diff --git a/cabal-validate/src/OutputUtil.hs b/cabal-validate/src/OutputUtil.hs index 28d4542f6a3..7e92cdf0362 100644 --- a/cabal-validate/src/OutputUtil.hs +++ b/cabal-validate/src/OutputUtil.hs @@ -1,3 +1,4 @@ +-- | Utilities for printing terminal output. module OutputUtil ( printHeader , withTiming @@ -19,10 +20,17 @@ import Cli (Opts (..)) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import System.Exit (exitFailure) +-- | Get the width of the current terminal, or 80 if no width can be determined. getTerminalWidth :: IO Int getTerminalWidth = maybe 80 Terminal.width <$> Terminal.size @Int -printHeader :: String -> IO () +-- | Print a header for a given step. +-- +-- This is colorful and hard to miss in the output. +printHeader + :: String + -- ^ Title to print. + -> IO () printHeader title = do columns <- getTerminalWidth let left = 3 @@ -37,7 +45,17 @@ printHeader title = do <> setSGRCode [Reset] putStrLn header -withTiming :: Opts -> String -> IO a -> IO a +-- | Run an `IO` action and print duration information after it finishes. +withTiming + :: Opts + -- ^ @cabal-validate@ options. + -> String + -- ^ Name for describing the action. + -- + -- Used in a sentence like "@title@ finished after 16.34s". + -> IO a + -- ^ Action to time. + -> IO a withTiming opts title action = do startTime' <- getAbsoluteTime diff --git a/cabal-validate/src/ProcessUtil.hs b/cabal-validate/src/ProcessUtil.hs index cefdb37d13c..e0cf0bd9fc8 100644 --- a/cabal-validate/src/ProcessUtil.hs +++ b/cabal-validate/src/ProcessUtil.hs @@ -1,3 +1,4 @@ +-- | Utilities for running processes and timing them. module ProcessUtil ( timed , timedWithCwd @@ -26,11 +27,33 @@ import System.Process.Typed (ExitCodeException (..), proc, readProcess, runProce import Cli (Opts (..)) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) -timedWithCwd :: Opts -> FilePath -> String -> [String] -> IO () +-- | Like `timed`, but runs the command in a given directory. +timedWithCwd + :: Opts + -- ^ @cabal-validate@ options. + -> FilePath + -- ^ Path to run the command in. + -> FilePath + -- ^ The command to run. + -> [String] + -- ^ Arguments to pass to the command. + -> IO () timedWithCwd opts cdPath command args = withCurrentDirectory cdPath (timed opts command args) -timed :: Opts -> String -> [String] -> IO () +-- | Run a command, displaying timing information after it finishes. +-- +-- This prints out the command to be executed before it's run, handles hiding +-- or showing output (according to the value of `verbose`), and throws an +-- `ExitCodeException` if the command fails. +timed + :: Opts + -- ^ @cabal-validate@ options. + -> FilePath + -- ^ The command to run. + -> [String] + -- ^ Arguments to pass to the command. + -> IO () timed opts command args = do let prettyCommand = displayCommand command args process = proc command args @@ -108,9 +131,13 @@ timed opts command args = do , eceStderr = rawStderr } +-- | Decode `ByteString` output from a command and strip whitespace at the +-- start and end. decodeStrip :: ByteString -> Text decodeStrip = T.strip . T.toStrict . T.decodeUtf8 +-- | Escape a shell command to display it to a user. +-- -- TODO: Shell escaping displayCommand :: String -> [String] -> String displayCommand command args = command <> " " <> unwords args diff --git a/cabal-validate/src/Step.hs b/cabal-validate/src/Step.hs index 34d771073dc..4fafc472061 100644 --- a/cabal-validate/src/Step.hs +++ b/cabal-validate/src/Step.hs @@ -1,3 +1,5 @@ +-- | The steps that can be run by @cabal-validate@. + module Step ( Step (..) , displayStep @@ -8,6 +10,7 @@ module Step import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +-- | A step to be run by @cabal-validate@. data Step = PrintConfig | PrintToolVersions @@ -23,6 +26,12 @@ data Step | TimeSummary deriving (Eq, Enum, Bounded, Show) +-- | Get the display identifier for a given `Step`. +-- +-- This is used to parse the @--step@ command-line argument. +-- +-- Note that these names are just kebab-case variants of the `Step` constructor +-- names; they do not attempt to describe the steps. displayStep :: Step -> String displayStep step = case step of @@ -39,6 +48,9 @@ displayStep step = SolverBenchmarksRun -> "solver-benchmarks-run" TimeSummary -> "time-summary" +-- | A map from step names to `Steps`. +-- +-- This is an inverse of `displayStep`. nameToStep :: Map String Step nameToStep = Map.fromList @@ -46,5 +58,6 @@ nameToStep = | step <- [minBound .. maxBound] ] +-- | Parse a string as a `Step`. parseStep :: String -> Maybe Step parseStep step = Map.lookup step nameToStep From 96d6ad541ff39d645d9762a6406cad2ce910f6fc Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 10:47:06 -0700 Subject: [PATCH 04/12] Remove `ansi-terminal` dependency --- cabal-validate/cabal-validate.cabal | 2 +- cabal-validate/src/ANSI.hs | 116 ++++++++++++++++++++++++++++ cabal-validate/src/Main.hs | 13 +--- cabal-validate/src/OutputUtil.hs | 21 ++--- cabal-validate/src/ProcessUtil.hs | 20 ++--- 5 files changed, 134 insertions(+), 38 deletions(-) create mode 100644 cabal-validate/src/ANSI.hs diff --git a/cabal-validate/cabal-validate.cabal b/cabal-validate/cabal-validate.cabal index ccd6762c6eb..582cf67434a 100644 --- a/cabal-validate/cabal-validate.cabal +++ b/cabal-validate/cabal-validate.cabal @@ -27,6 +27,7 @@ executable cabal-validate hs-source-dirs: src other-modules: + , ANSI , Cli , ClockUtil , OutputUtil @@ -35,7 +36,6 @@ executable cabal-validate build-depends: , base >=4 && <5 - , ansi-terminal >=1 && <2 , bytestring >=0.11 && <1 , containers >=0.6 && <1 , directory >=1.0 && <2 diff --git a/cabal-validate/src/ANSI.hs b/cabal-validate/src/ANSI.hs new file mode 100644 index 00000000000..79dabf66d77 --- /dev/null +++ b/cabal-validate/src/ANSI.hs @@ -0,0 +1,116 @@ +-- | ANSI escape sequences. +-- +-- This is a stripped-down version of the parts of the @ansi-terminal@ package +-- we use. +-- +-- See: + +module ANSI + ( SGR(..) + , setSGR + ) where + + +-- | Render a single numeric SGR sequence. +rawSGR :: Int -> String +rawSGR code = "\x1b[" <> show code <> "m" + +-- | Render a series of `SGR` escape sequences. +setSGR :: [SGR] -> String +setSGR = concat . map renderSGR + +-- | All of the SGR sequences we want to use. +data SGR + = Reset + | Bold + | Dim + | Italic + | Underline + + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | Default + + | OnBlack + | OnRed + | OnGreen + | OnYellow + | OnBlue + | OnMagenta + | OnCyan + | OnWhite + | OnDefault + + | BoldBlack + | BoldRed + | BoldGreen + | BoldYellow + | BoldBlue + | BoldMagenta + | BoldCyan + | BoldWhite + + | OnBoldBlack + | OnBoldRed + | OnBoldGreen + | OnBoldYellow + | OnBoldBlue + | OnBoldMagenta + | OnBoldCyan + | OnBoldWhite + + deriving (Show) + +-- Render a single `SGR` sequence. +renderSGR :: SGR -> String +renderSGR code = + case code of + Reset -> rawSGR 0 + Bold -> rawSGR 1 + Dim -> rawSGR 2 + Italic -> rawSGR 3 + Underline -> rawSGR 4 + + Black -> rawSGR 30 + Red -> rawSGR 31 + Green -> rawSGR 32 + Yellow -> rawSGR 33 + Blue -> rawSGR 34 + Magenta -> rawSGR 35 + Cyan -> rawSGR 36 + White -> rawSGR 37 + Default -> rawSGR 39 + + OnBlack -> rawSGR 40 + OnRed -> rawSGR 41 + OnGreen -> rawSGR 42 + OnYellow -> rawSGR 43 + OnBlue -> rawSGR 44 + OnMagenta -> rawSGR 45 + OnCyan -> rawSGR 46 + OnWhite -> rawSGR 47 + OnDefault -> rawSGR 49 + + BoldBlack -> rawSGR 90 + BoldRed -> rawSGR 91 + BoldGreen -> rawSGR 92 + BoldYellow -> rawSGR 93 + BoldBlue -> rawSGR 94 + BoldMagenta -> rawSGR 95 + BoldCyan -> rawSGR 96 + BoldWhite -> rawSGR 97 + + OnBoldBlack -> rawSGR 100 + OnBoldRed -> rawSGR 101 + OnBoldGreen -> rawSGR 102 + OnBoldYellow -> rawSGR 103 + OnBoldBlue -> rawSGR 104 + OnBoldMagenta -> rawSGR 105 + OnBoldCyan -> rawSGR 106 + OnBoldWhite -> rawSGR 107 diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs index c75c97baac5..2361179eeed 100644 --- a/cabal-validate/src/Main.hs +++ b/cabal-validate/src/Main.hs @@ -13,17 +13,10 @@ import qualified Data.Text.IO as T import qualified Data.Text.Lazy as T (toStrict) import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) import Data.Version (makeVersion, showVersion) -import System.Console.ANSI - ( Color (Cyan) - , ColorIntensity (Vivid) - , ConsoleIntensity (BoldIntensity) - , ConsoleLayer (Foreground) - , SGR (Reset, SetColor, SetConsoleIntensity) - , setSGRCode - ) import System.FilePath (()) import System.Process.Typed (proc, readProcessStdout_) +import ANSI (SGR (BoldCyan, Reset), setSGR) import Cli (Compiler (..), HackageTests (..), Opts (..), parseOpts) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import OutputUtil (printHeader, withTiming) @@ -424,7 +417,7 @@ timeSummary opts = do endTime <- getAbsoluteTime let totalDuration = diffAbsoluteTime endTime (startTime opts) putStrLn $ - setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + setSGR [BoldCyan] <> "!!! Validation completed in " <> formatDiffTime totalDuration - <> setSGRCode [Reset] + <> setSGR [Reset] diff --git a/cabal-validate/src/OutputUtil.hs b/cabal-validate/src/OutputUtil.hs index 7e92cdf0362..afe6f96030f 100644 --- a/cabal-validate/src/OutputUtil.hs +++ b/cabal-validate/src/OutputUtil.hs @@ -5,17 +5,10 @@ module OutputUtil ) where import Control.Exception (catch) -import System.Console.ANSI - ( Color (Cyan, Green, Red) - , ColorIntensity (Vivid) - , ConsoleIntensity (BoldIntensity) - , ConsoleLayer (Foreground) - , SGR (Reset, SetColor, SetConsoleIntensity) - , setSGRCode - ) import qualified System.Console.Terminal.Size as Terminal import System.Process.Typed (ExitCodeException) +import ANSI (SGR (BoldCyan, BoldGreen, BoldRed, Reset), setSGR) import Cli (Opts (..)) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import System.Exit (exitFailure) @@ -36,13 +29,13 @@ printHeader title = do let left = 3 right = columns - length title - left - 2 header = - setSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + setSGR [BoldCyan] <> replicate left '═' <> " " <> title <> " " <> replicate right '═' - <> setSGRCode [Reset] + <> setSGR [Reset] putStrLn header -- | Run an `IO` action and print duration information after it finishes. @@ -71,24 +64,24 @@ withTiming opts title action = do case result of Right inner -> do putStrLn $ - setSGRCode [SetColor Foreground Vivid Green] + setSGR [BoldGreen] <> title <> " finished after " <> formatDiffTime duration <> "\nTotal time so far: " <> formatDiffTime totalDuration - <> setSGRCode [Reset] + <> setSGR [Reset] pure inner Left _procFailed -> do putStrLn $ - setSGRCode [SetColor Foreground Vivid Red] + setSGR [BoldRed] <> title <> " failed after " <> formatDiffTime duration <> "\nTotal time so far: " <> formatDiffTime totalDuration - <> setSGRCode [Reset] + <> setSGR [Reset] -- TODO: `--keep-going` mode. exitFailure diff --git a/cabal-validate/src/ProcessUtil.hs b/cabal-validate/src/ProcessUtil.hs index e0cf0bd9fc8..19e987d5941 100644 --- a/cabal-validate/src/ProcessUtil.hs +++ b/cabal-validate/src/ProcessUtil.hs @@ -13,17 +13,11 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as T (toStrict) import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) -import System.Console.ANSI - ( Color (Blue, Green, Red) - , ColorIntensity (Vivid) - , ConsoleLayer (Foreground) - , SGR (Reset, SetColor) - , setSGRCode - ) import System.Directory (withCurrentDirectory) import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.Process.Typed (ExitCodeException (..), proc, readProcess, runProcess) +import ANSI (SGR (BoldBlue, BoldGreen, BoldRed, Reset), setSGR) import Cli (Opts (..)) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) @@ -62,10 +56,10 @@ timed opts command args = do -- TODO: Replace `$HOME` or `opts.cwd` for brevity? putStrLn $ - setSGRCode [SetColor Foreground Vivid Blue] + setSGR [BoldBlue] <> "$ " <> prettyCommand - <> setSGRCode [Reset] + <> setSGR [Reset] (exitCode, rawStdout, rawStderr) <- if verbose opts @@ -99,20 +93,20 @@ timed opts command args = do <> T.unlines tailLines putStrLn $ - setSGRCode [SetColor Foreground Vivid Green] + setSGR [BoldGreen] <> "Finished after " <> formatDiffTime duration <> ": " <> prettyCommand <> "\nTotal time so far: " <> formatDiffTime totalDuration - <> setSGRCode [Reset] + <> setSGR [Reset] ExitFailure exitCode' -> do unless (verbose opts) $ do T.putStrLn output putStrLn $ - setSGRCode [SetColor Foreground Vivid Red] + setSGR [BoldRed] <> "Failed with exit code " <> show exitCode' <> " after " @@ -121,7 +115,7 @@ timed opts command args = do <> prettyCommand <> "\nTotal time so far: " <> formatDiffTime totalDuration - <> setSGRCode [Reset] + <> setSGR [Reset] throwIO ExitCodeException From 9f5d90f5b1df939d92ca5c30cd0501307c73ee6e Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 10:53:47 -0700 Subject: [PATCH 05/12] Use `unlines` in `printConfig` --- cabal-validate/src/Main.hs | 36 +++++++++++++++++++----------------- 1 file changed, 19 insertions(+), 17 deletions(-) diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs index 2361179eeed..590cc39167e 100644 --- a/cabal-validate/src/Main.hs +++ b/cabal-validate/src/Main.hs @@ -140,23 +140,25 @@ timedCabalBin opts package component args = do -- | Print the configuration for CI logs. printConfig :: Opts -> IO () printConfig opts = do - putStrLn $ - "compiler: " - <> compilerExecutable (compiler opts) - <> "\ncabal-install: " - <> cabal opts - <> "\njobs: " - <> show (jobs opts) - <> "\nsteps: " - <> unwords (map displayStep (steps opts)) - <> "\nHackage tests: " - <> show (hackageTests opts) - <> "\nverbose: " - <> show (verbose opts) - <> "\nextra compilers: " - <> unwords (extraCompilers opts) - <> "\nextra RTS options: " - <> unwords (rtsArgs opts) + putStr $ + unlines + [ "compiler: " + <> compilerExecutable (compiler opts) + , "cabal-install: " + <> cabal opts + , "jobs: " + <> show (jobs opts) + , "steps: " + <> unwords (map displayStep (steps opts)) + , "Hackage tests: " + <> show (hackageTests opts) + , "verbose: " + <> show (verbose opts) + , "extra compilers: " + <> unwords (extraCompilers opts) + , "extra RTS options: " + <> unwords (rtsArgs opts) + ] -- | Print the versions of tools being used. printToolVersions :: Opts -> IO () From a10a2a3d3f7321acbe3bddacc0eace81b4389f94 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 11:05:32 -0700 Subject: [PATCH 06/12] optsParser -> rawOptsParser --- cabal-validate/src/Cli.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs index c0988d2ead4..d0478b90d64 100644 --- a/cabal-validate/src/Cli.hs +++ b/cabal-validate/src/Cli.hs @@ -267,7 +267,8 @@ resolveOpts opts = do , steps = steps' } --- | Raw command-line options. +-- | Literate command-line options as supplied by the user, before resolving +-- defaults and other values from the environment. data RawOpts = RawOpts { rawVerbose :: Bool , rawJobs :: Maybe Int @@ -290,9 +291,9 @@ data RawOpts = RawOpts -- | `Parser` for `RawOpts`. -- --- See: `fullOptsParser` -optsParser :: Parser RawOpts -optsParser = +-- See: `fullRawOptsParser` +rawOptsParser :: Parser RawOpts +rawOptsParser = RawOpts <$> ( flag' True @@ -419,10 +420,10 @@ boolOption defaultValue trueName = -- | Full `Parser` for `RawOpts`, which includes a @--help@ argument and -- information about the program. -fullOptsParser :: ParserInfo RawOpts -fullOptsParser = +fullRawOptsParser :: ParserInfo RawOpts +fullRawOptsParser = info - (optsParser <**> helper) + (rawOptsParser <**> helper) ( fullDesc <> progDesc "Test suite runner for `Cabal` and `cabal-install` developers" ) @@ -430,4 +431,4 @@ fullOptsParser = -- | Parse command-line arguments and resolve defaults from the environment, -- producing `Opts`. parseOpts :: IO Opts -parseOpts = execParser fullOptsParser >>= resolveOpts +parseOpts = execParser fullRawOptsParser >>= resolveOpts From 37cfe85b69ddc9be53d7172d7815ad801a0e2aff Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 11:05:49 -0700 Subject: [PATCH 07/12] withTiming: take `startTime` explicitly --- cabal-validate/src/Main.hs | 2 +- cabal-validate/src/OutputUtil.hs | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs index 590cc39167e..79a8df67e7c 100644 --- a/cabal-validate/src/Main.hs +++ b/cabal-validate/src/Main.hs @@ -48,7 +48,7 @@ runStep opts step = do SolverBenchmarksTests -> solverBenchmarksTests opts SolverBenchmarksRun -> solverBenchmarksRun opts TimeSummary -> timeSummary opts - withTiming opts title action + withTiming (startTime opts) title action T.putStrLn "" -- | Compiler with version number like @ghc-9.6.6@. diff --git a/cabal-validate/src/OutputUtil.hs b/cabal-validate/src/OutputUtil.hs index afe6f96030f..075368def8c 100644 --- a/cabal-validate/src/OutputUtil.hs +++ b/cabal-validate/src/OutputUtil.hs @@ -9,8 +9,7 @@ import qualified System.Console.Terminal.Size as Terminal import System.Process.Typed (ExitCodeException) import ANSI (SGR (BoldCyan, BoldGreen, BoldRed, Reset), setSGR) -import Cli (Opts (..)) -import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) +import ClockUtil (AbsoluteTime, diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import System.Exit (exitFailure) -- | Get the width of the current terminal, or 80 if no width can be determined. @@ -40,8 +39,8 @@ printHeader title = do -- | Run an `IO` action and print duration information after it finishes. withTiming - :: Opts - -- ^ @cabal-validate@ options. + :: AbsoluteTime + -- ^ Start time for the whole @cabal-validate@ run. -> String -- ^ Name for describing the action. -- @@ -49,7 +48,7 @@ withTiming -> IO a -- ^ Action to time. -> IO a -withTiming opts title action = do +withTiming startTime title action = do startTime' <- getAbsoluteTime result <- @@ -59,7 +58,7 @@ withTiming opts title action = do endTime <- getAbsoluteTime let duration = diffAbsoluteTime endTime startTime' - totalDuration = diffAbsoluteTime endTime (startTime opts) + totalDuration = diffAbsoluteTime endTime startTime case result of Right inner -> do From 92613f0efb614d85b290a4c179fa72a23889f695 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 11:15:14 -0700 Subject: [PATCH 08/12] Add `cabal-validate` to `format` job --- .github/workflows/format.yml | 1 + cabal-validate/src/ANSI.hs | 13 +----- cabal-validate/src/Cli.hs | 73 ++++++++++++++++---------------- cabal-validate/src/ClockUtil.hs | 1 - cabal-validate/src/OutputUtil.hs | 2 +- cabal-validate/src/Step.hs | 1 - 6 files changed, 39 insertions(+), 52 deletions(-) diff --git a/.github/workflows/format.yml b/.github/workflows/format.yml index d54310be613..116537cf2ea 100644 --- a/.github/workflows/format.yml +++ b/.github/workflows/format.yml @@ -17,3 +17,4 @@ jobs: Cabal/**/*.hs Cabal-syntax/**/*.hs cabal-install/**/*.hs + cabal-validate/**/*.hs diff --git a/cabal-validate/src/ANSI.hs b/cabal-validate/src/ANSI.hs index 79dabf66d77..460261dcde4 100644 --- a/cabal-validate/src/ANSI.hs +++ b/cabal-validate/src/ANSI.hs @@ -4,13 +4,11 @@ -- we use. -- -- See: - module ANSI - ( SGR(..) + ( SGR (..) , setSGR ) where - -- | Render a single numeric SGR sequence. rawSGR :: Int -> String rawSGR code = "\x1b[" <> show code <> "m" @@ -26,7 +24,6 @@ data SGR | Dim | Italic | Underline - | Black | Red | Green @@ -36,7 +33,6 @@ data SGR | Cyan | White | Default - | OnBlack | OnRed | OnGreen @@ -46,7 +42,6 @@ data SGR | OnCyan | OnWhite | OnDefault - | BoldBlack | BoldRed | BoldGreen @@ -55,7 +50,6 @@ data SGR | BoldMagenta | BoldCyan | BoldWhite - | OnBoldBlack | OnBoldRed | OnBoldGreen @@ -64,7 +58,6 @@ data SGR | OnBoldMagenta | OnBoldCyan | OnBoldWhite - deriving (Show) -- Render a single `SGR` sequence. @@ -76,7 +69,6 @@ renderSGR code = Dim -> rawSGR 2 Italic -> rawSGR 3 Underline -> rawSGR 4 - Black -> rawSGR 30 Red -> rawSGR 31 Green -> rawSGR 32 @@ -86,7 +78,6 @@ renderSGR code = Cyan -> rawSGR 36 White -> rawSGR 37 Default -> rawSGR 39 - OnBlack -> rawSGR 40 OnRed -> rawSGR 41 OnGreen -> rawSGR 42 @@ -96,7 +87,6 @@ renderSGR code = OnCyan -> rawSGR 46 OnWhite -> rawSGR 47 OnDefault -> rawSGR 49 - BoldBlack -> rawSGR 90 BoldRed -> rawSGR 91 BoldGreen -> rawSGR 92 @@ -105,7 +95,6 @@ renderSGR code = BoldMagenta -> rawSGR 95 BoldCyan -> rawSGR 96 BoldWhite -> rawSGR 97 - OnBoldBlack -> rawSGR 100 OnBoldRed -> rawSGR 101 OnBoldGreen -> rawSGR 102 diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs index d0478b90d64..074739676ff 100644 --- a/cabal-validate/src/Cli.hs +++ b/cabal-validate/src/Cli.hs @@ -1,5 +1,4 @@ -- | Parse CLI arguments and resolve defaults from the environment. - module Cli ( Opts (..) , parseOpts @@ -55,57 +54,57 @@ import Step (Step (..), displayStep, parseStep) -- | Command-line options, resolved with context from the environment. data Opts = Opts { verbose :: Bool - -- ^ Whether to display build and test output. + -- ^ Whether to display build and test output. , jobs :: Int - -- ^ How many jobs to use when running tests. - -- - -- Defaults to the number of physical cores. + -- ^ How many jobs to use when running tests. + -- + -- Defaults to the number of physical cores. , cwd :: FilePath - -- ^ Current working directory when @cabal-validate@ was started. + -- ^ Current working directory when @cabal-validate@ was started. , startTime :: AbsoluteTime - -- ^ System time when @cabal-validate@ was started. - -- - -- Used to determine the total test duration so far. + -- ^ System time when @cabal-validate@ was started. + -- + -- Used to determine the total test duration so far. , compiler :: Compiler - -- ^ Compiler to build Cabal with. - -- - -- Defaults to @ghc@. + -- ^ Compiler to build Cabal with. + -- + -- Defaults to @ghc@. , extraCompilers :: [FilePath] - -- ^ Extra compilers to run @cabal-testsuite@ with. + -- ^ Extra compilers to run @cabal-testsuite@ with. , cabal :: FilePath - -- ^ @cabal-install@ to build Cabal with. - -- - -- Defaults to @cabal@. + -- ^ @cabal-install@ to build Cabal with. + -- + -- Defaults to @cabal@. , hackageTests :: HackageTests - -- ^ Whether to run tests on Hackage data, and if so how much. - -- - -- Defaults to `NoHackageTests`. + -- ^ Whether to run tests on Hackage data, and if so how much. + -- + -- Defaults to `NoHackageTests`. , archPath :: FilePath - -- ^ The path for this system's architecture within the build directory. - -- - -- Like @x86_64-windows@ or @aarch64-osx@ or @arm-linux@. + -- ^ The path for this system's architecture within the build directory. + -- + -- Like @x86_64-windows@ or @aarch64-osx@ or @arm-linux@. , projectFile :: FilePath - -- ^ Path to the @cabal.project@ file to use for running tests. + -- ^ Path to the @cabal.project@ file to use for running tests. , tastyArgs :: [String] - -- ^ Extra arguments to pass to @tasty@ test suites. - -- - -- This defaults to @--hide-successes@ (which cannot yet be changed) and - -- includes the @--pattern@ argument if one is given. + -- ^ Extra arguments to pass to @tasty@ test suites. + -- + -- This defaults to @--hide-successes@ (which cannot yet be changed) and + -- includes the @--pattern@ argument if one is given. , targets :: [String] - -- ^ Targets to build. + -- ^ Targets to build. , steps :: [Step] - -- ^ Steps to run. + -- ^ Steps to run. } deriving (Show) -- | Whether to run tests on Hackage data, and if so how much. data HackageTests - = CompleteHackageTests - -- ^ Run tests on complete Hackage data. - | PartialHackageTests - -- ^ Run tests on partial Hackage data. - | NoHackageTests - -- ^ Do not run tests on Hackage data. + = -- | Run tests on complete Hackage data. + CompleteHackageTests + | -- | Run tests on partial Hackage data. + PartialHackageTests + | -- | Do not run tests on Hackage data. + NoHackageTests deriving (Show) -- | A compiler executable and version number. @@ -120,9 +119,9 @@ data Compiler = Compiler -- | An `Exception` thrown when parsing @--numeric-version@ output from a compiler. data VersionParseException = VersionParseException { versionInput :: String - -- ^ The string we attempted to parse. + -- ^ The string we attempted to parse. , versionExecutable :: FilePath - -- ^ The compiler which produced the string. + -- ^ The compiler which produced the string. } deriving (Typeable, Show) diff --git a/cabal-validate/src/ClockUtil.hs b/cabal-validate/src/ClockUtil.hs index 664175789e7..2df7cdd9866 100644 --- a/cabal-validate/src/ClockUtil.hs +++ b/cabal-validate/src/ClockUtil.hs @@ -1,5 +1,4 @@ -- | Utilities for dealing with times and durations. - module ClockUtil ( DiffTime , AbsoluteTime diff --git a/cabal-validate/src/OutputUtil.hs b/cabal-validate/src/OutputUtil.hs index 075368def8c..36e5acc6a37 100644 --- a/cabal-validate/src/OutputUtil.hs +++ b/cabal-validate/src/OutputUtil.hs @@ -9,7 +9,7 @@ import qualified System.Console.Terminal.Size as Terminal import System.Process.Typed (ExitCodeException) import ANSI (SGR (BoldCyan, BoldGreen, BoldRed, Reset), setSGR) -import ClockUtil (AbsoluteTime, diffAbsoluteTime, formatDiffTime, getAbsoluteTime) +import ClockUtil (AbsoluteTime, diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import System.Exit (exitFailure) -- | Get the width of the current terminal, or 80 if no width can be determined. diff --git a/cabal-validate/src/Step.hs b/cabal-validate/src/Step.hs index 4fafc472061..2636f483a79 100644 --- a/cabal-validate/src/Step.hs +++ b/cabal-validate/src/Step.hs @@ -1,5 +1,4 @@ -- | The steps that can be run by @cabal-validate@. - module Step ( Step (..) , displayStep From d208282148723fbdb6b433fe9152fa3d140a86ed Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 12:39:52 -0700 Subject: [PATCH 09/12] Build test suites explicitly This seems to fix an error where `long-tests` isn't built? --- cabal-validate/src/Cli.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs index 074739676ff..996e49205c0 100644 --- a/cabal-validate/src/Cli.hs +++ b/cabal-validate/src/Cli.hs @@ -208,10 +208,16 @@ resolveOpts opts = do , optionals (CliTests `elem` steps') [ "cabal-install" + , "cabal-install:tests" , "cabal-install-solver" , "cabal-benchmarks" + , "Cabal-tests:tests" + ] + , optionals + (rawSolverBenchmarks opts) + [ "solver-benchmarks" + , "solver-benchmarks:tests" ] - , optional (rawSolverBenchmarks opts) "solver-benchmarks" ] archPath' = From bae200a4c89b2bf3aa6482da0939ee373fd4f6c6 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 12:53:07 -0700 Subject: [PATCH 10/12] fixup! Remove `ansi-terminal` dependency --- cabal-validate/src/ANSI.hs | 64 +++++++++++++++---------------- cabal-validate/src/Main.hs | 4 +- cabal-validate/src/OutputUtil.hs | 8 ++-- cabal-validate/src/ProcessUtil.hs | 8 ++-- 4 files changed, 42 insertions(+), 42 deletions(-) diff --git a/cabal-validate/src/ANSI.hs b/cabal-validate/src/ANSI.hs index 460261dcde4..a0d9111d957 100644 --- a/cabal-validate/src/ANSI.hs +++ b/cabal-validate/src/ANSI.hs @@ -42,22 +42,22 @@ data SGR | OnCyan | OnWhite | OnDefault - | BoldBlack - | BoldRed - | BoldGreen - | BoldYellow - | BoldBlue - | BoldMagenta - | BoldCyan - | BoldWhite - | OnBoldBlack - | OnBoldRed - | OnBoldGreen - | OnBoldYellow - | OnBoldBlue - | OnBoldMagenta - | OnBoldCyan - | OnBoldWhite + | BrightBlack + | BrightRed + | BrightGreen + | BrightYellow + | BrightBlue + | BrightMagenta + | BrightCyan + | BrightWhite + | OnBrightBlack + | OnBrightRed + | OnBrightGreen + | OnBrightYellow + | OnBrightBlue + | OnBrightMagenta + | OnBrightCyan + | OnBrightWhite deriving (Show) -- Render a single `SGR` sequence. @@ -87,19 +87,19 @@ renderSGR code = OnCyan -> rawSGR 46 OnWhite -> rawSGR 47 OnDefault -> rawSGR 49 - BoldBlack -> rawSGR 90 - BoldRed -> rawSGR 91 - BoldGreen -> rawSGR 92 - BoldYellow -> rawSGR 93 - BoldBlue -> rawSGR 94 - BoldMagenta -> rawSGR 95 - BoldCyan -> rawSGR 96 - BoldWhite -> rawSGR 97 - OnBoldBlack -> rawSGR 100 - OnBoldRed -> rawSGR 101 - OnBoldGreen -> rawSGR 102 - OnBoldYellow -> rawSGR 103 - OnBoldBlue -> rawSGR 104 - OnBoldMagenta -> rawSGR 105 - OnBoldCyan -> rawSGR 106 - OnBoldWhite -> rawSGR 107 + BrightBlack -> rawSGR 90 + BrightRed -> rawSGR 91 + BrightGreen -> rawSGR 92 + BrightYellow -> rawSGR 93 + BrightBlue -> rawSGR 94 + BrightMagenta -> rawSGR 95 + BrightCyan -> rawSGR 96 + BrightWhite -> rawSGR 97 + OnBrightBlack -> rawSGR 100 + OnBrightRed -> rawSGR 101 + OnBrightGreen -> rawSGR 102 + OnBrightYellow -> rawSGR 103 + OnBrightBlue -> rawSGR 104 + OnBrightMagenta -> rawSGR 105 + OnBrightCyan -> rawSGR 106 + OnBrightWhite -> rawSGR 107 diff --git a/cabal-validate/src/Main.hs b/cabal-validate/src/Main.hs index 79a8df67e7c..428a8a7358d 100644 --- a/cabal-validate/src/Main.hs +++ b/cabal-validate/src/Main.hs @@ -16,7 +16,7 @@ import Data.Version (makeVersion, showVersion) import System.FilePath (()) import System.Process.Typed (proc, readProcessStdout_) -import ANSI (SGR (BoldCyan, Reset), setSGR) +import ANSI (SGR (Bold, BrightCyan, Reset), setSGR) import Cli (Compiler (..), HackageTests (..), Opts (..), parseOpts) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import OutputUtil (printHeader, withTiming) @@ -419,7 +419,7 @@ timeSummary opts = do endTime <- getAbsoluteTime let totalDuration = diffAbsoluteTime endTime (startTime opts) putStrLn $ - setSGR [BoldCyan] + setSGR [Bold, BrightCyan] <> "!!! Validation completed in " <> formatDiffTime totalDuration <> setSGR [Reset] diff --git a/cabal-validate/src/OutputUtil.hs b/cabal-validate/src/OutputUtil.hs index 36e5acc6a37..576c6180433 100644 --- a/cabal-validate/src/OutputUtil.hs +++ b/cabal-validate/src/OutputUtil.hs @@ -8,7 +8,7 @@ import Control.Exception (catch) import qualified System.Console.Terminal.Size as Terminal import System.Process.Typed (ExitCodeException) -import ANSI (SGR (BoldCyan, BoldGreen, BoldRed, Reset), setSGR) +import ANSI (SGR (Bold, BrightCyan, BrightGreen, BrightRed, Reset), setSGR) import ClockUtil (AbsoluteTime, diffAbsoluteTime, formatDiffTime, getAbsoluteTime) import System.Exit (exitFailure) @@ -28,7 +28,7 @@ printHeader title = do let left = 3 right = columns - length title - left - 2 header = - setSGR [BoldCyan] + setSGR [Bold, BrightCyan] <> replicate left '═' <> " " <> title @@ -63,7 +63,7 @@ withTiming startTime title action = do case result of Right inner -> do putStrLn $ - setSGR [BoldGreen] + setSGR [Bold, BrightGreen] <> title <> " finished after " <> formatDiffTime duration @@ -74,7 +74,7 @@ withTiming startTime title action = do pure inner Left _procFailed -> do putStrLn $ - setSGR [BoldRed] + setSGR [Bold, BrightRed] <> title <> " failed after " <> formatDiffTime duration diff --git a/cabal-validate/src/ProcessUtil.hs b/cabal-validate/src/ProcessUtil.hs index 19e987d5941..3e27f5517a1 100644 --- a/cabal-validate/src/ProcessUtil.hs +++ b/cabal-validate/src/ProcessUtil.hs @@ -17,7 +17,7 @@ import System.Directory (withCurrentDirectory) import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.Process.Typed (ExitCodeException (..), proc, readProcess, runProcess) -import ANSI (SGR (BoldBlue, BoldGreen, BoldRed, Reset), setSGR) +import ANSI (SGR (BrightBlue, BrightGreen, BrightRed, Reset), setSGR) import Cli (Opts (..)) import ClockUtil (diffAbsoluteTime, formatDiffTime, getAbsoluteTime) @@ -56,7 +56,7 @@ timed opts command args = do -- TODO: Replace `$HOME` or `opts.cwd` for brevity? putStrLn $ - setSGR [BoldBlue] + setSGR [BrightBlue] <> "$ " <> prettyCommand <> setSGR [Reset] @@ -93,7 +93,7 @@ timed opts command args = do <> T.unlines tailLines putStrLn $ - setSGR [BoldGreen] + setSGR [BrightGreen] <> "Finished after " <> formatDiffTime duration <> ": " @@ -106,7 +106,7 @@ timed opts command args = do T.putStrLn output putStrLn $ - setSGR [BoldRed] + setSGR [BrightRed] <> "Failed with exit code " <> show exitCode' <> " after " From 1900d5e9dc200be7764521b7523fa47b631902f9 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 14:36:40 -0700 Subject: [PATCH 11/12] fixup! Build test suites explicitly --- cabal-validate/src/Cli.hs | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs index 996e49205c0..fed3661a937 100644 --- a/cabal-validate/src/Cli.hs +++ b/cabal-validate/src/Cli.hs @@ -204,15 +204,10 @@ resolveOpts opts = do , "Cabal-QuickCheck" , "Cabal-tree-diff" , "Cabal-described" + , "cabal-install" + , "cabal-install-solver" + , "cabal-benchmarks" ] - , optionals - (CliTests `elem` steps') - [ "cabal-install" - , "cabal-install:tests" - , "cabal-install-solver" - , "cabal-benchmarks" - , "Cabal-tests:tests" - ] , optionals (rawSolverBenchmarks opts) [ "solver-benchmarks" From 30f0faa3c43d66257501e9aed47260e0eccb9e45 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Mon, 30 Sep 2024 15:35:16 -0700 Subject: [PATCH 12/12] fixup! fixup! Build test suites explicitly --- cabal-validate/src/Cli.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/cabal-validate/src/Cli.hs b/cabal-validate/src/Cli.hs index fed3661a937..ef01d907594 100644 --- a/cabal-validate/src/Cli.hs +++ b/cabal-validate/src/Cli.hs @@ -204,10 +204,13 @@ resolveOpts opts = do , "Cabal-QuickCheck" , "Cabal-tree-diff" , "Cabal-described" - , "cabal-install" - , "cabal-install-solver" - , "cabal-benchmarks" ] + , optionals + (not (rawLibOnly opts)) + [ "cabal-install" + , "cabal-install-solver" + , "cabal-benchmarks" + ] , optionals (rawSolverBenchmarks opts) [ "solver-benchmarks"