diff --git a/Makefile b/Makefile index 835c73b8ff9..ddb7dd9a303 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..315604a2f8e --- /dev/null +++ b/cabal-validate/cabal-validate.cabal @@ -0,0 +1,40 @@ +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 + , NoFieldSelectors + , DuplicateRecordFields + , OverloadedRecordDot + , 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 + , turtle >=1 && <2 + , optparse-applicative >=0.18 && <1 + , containers >=0.6 && <1 + , directory >=1.0 && <2 + , text >=2 && <3 + , terminal-size >=0.3 && <1 + , time >=1 && <2 diff --git a/cabal-validate/main/Main.hs b/cabal-validate/main/Main.hs new file mode 100644 index 00000000000..fbe8a5aeff1 --- /dev/null +++ b/cabal-validate/main/Main.hs @@ -0,0 +1,955 @@ +module Main where + +import Control.Applicative (Alternative (many, (<|>)), (<**>)) +import Control.Exception (Exception (displayException), catch, throw, throwIO) +import Control.Monad (forM_, unless) +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 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 System.Console.Terminal.Size (Window (width), size) +import System.Directory (getCurrentDirectory) +import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitFailure, exitSuccess) +import System.Info (arch, fullCompilerVersion, os) +import Text.ParserCombinators.ReadP (readP_to_S) +import Turtle (ProcFailed (ProcFailed, procArguments, procCommand, procExitCode), cd, proc, procStrict, when, ()) + +tPutStrLn :: Text -> IO () +tPutStrLn = putStrLn . T.unpack + +tShow :: Show a => a -> Text +tShow = T.pack . show + +tSetSGRCode :: [SGR] -> Text +tSetSGRCode = T.pack . setSGRCode + +-- | 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 :: [Text] + , targets :: [Text] + , steps :: [Step] + } + deriving (Show) + +data Compiler = Compiler + { executable :: FilePath + , version :: Version + } + deriving (Show) + +data VersionParseException = VersionParseException + { input :: String + , executable :: FilePath + } + deriving (Typeable, Show) + +instance Exception VersionParseException where + displayException exception = + "Failed to parse `" + <> exception.executable + <> " --numeric-version` output: " + <> show exception.input + +makeCompiler :: FilePath -> IO Compiler +makeCompiler executable = do + -- TODO: Check the exit code! + (_exitCode, stdout) <- procStrict (T.pack executable) ["--numeric-version"] "" + let version = T.unpack $ T.strip stdout + parsedVersions = readP_to_S parseVersion version + -- Who needs error messages? Those aren't in the API. + maybeParsedVersion = + listToMaybe + [ parsed + | (parsed, rest) <- parsedVersions + , null rest + ] + parsedVersion = case maybeParsedVersion of + Just parsedVersion' -> parsedVersion' + Nothing -> + throw + VersionParseException + { input = version + , executable = executable + } + + pure + Compiler + { executable = executable + , version = parsedVersion + } + +baseHc :: ResolvedOpts -> FilePath +baseHc opts = "ghc-" <> showVersion opts.compiler.version + +baseBuildDir :: ResolvedOpts -> FilePath +baseBuildDir opts = "dist-newstyle-validate-" <> baseHc opts + +buildDir :: ResolvedOpts -> FilePath +buildDir opts = + opts.cwd + baseBuildDir opts + "build" + opts.archPath + baseHc opts + +jobsArgs :: ResolvedOpts -> [Text] +jobsArgs opts = ["--num-threads", tShow opts.jobs] + +cabalArgs :: ResolvedOpts -> [Text] +cabalArgs opts = + [ "--jobs=" <> tShow opts.jobs + , "--with-compiler=" <> T.pack opts.compiler.executable + , "--builddir=" <> T.pack (baseBuildDir opts) + , "--project-file=" <> T.pack opts.projectFile + ] + +cabalTestsuiteBuildDir :: ResolvedOpts -> FilePath +cabalTestsuiteBuildDir opts = + buildDir opts + "cabal-testsuite-3" + +cabalNewBuildArgs :: ResolvedOpts -> [Text] +cabalNewBuildArgs opts = "build" : cabalArgs opts + +cabalListBinArgs :: ResolvedOpts -> [Text] +cabalListBinArgs opts = "list-bin" : cabalArgs opts + +cabalListBin :: ResolvedOpts -> Text -> IO Text +cabalListBin opts target = do + let command = T.pack opts.cabal + args = cabalListBinArgs opts ++ [target] + (exitCode, rawOutput) <- procStrict command args "" + + case exitCode of + ExitSuccess -> pure (T.strip rawOutput) + ExitFailure _ -> + throwIO + ProcFailed + { procCommand = command + , procArguments = args + , procExitCode = exitCode + } + +rtsArgs :: ResolvedOpts -> [Text] +rtsArgs opts = + case opts.archPath of + "x86_64-windows" -> + -- See: https://github.com/haskell/cabal/issues/9571 + if fullCompilerVersion > 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 opts.steps) + then opts.steps + else + concat + [ + [ PrintConfig + , PrintToolVersions + , Build + ] + , optional opts.doctest Doctest + , optional opts.runLibTests LibTests + , optional opts.runLibSuite LibSuite + , optional (opts.runLibSuite && not (null opts.extraCompilers)) LibSuiteExtras + , optional (opts.runCliTests && not opts.libOnly) CliTests + , optional (opts.runCliSuite && not opts.libOnly) CliSuite + , optionals opts.solverBenchmarks [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 opts.solverBenchmarks "solver-benchmarks" + ] + + archPath = + let osPath = + case os of + "darwin" -> "osx" + "linux" -> "linux" + "mingw32" -> "windows" + _ -> os -- TODO: Warning? + in arch <> "-" <> osPath + + projectFile = + if opts.libOnly + then "cabal.validate-libonly.project" + else "cabal.validate.project" + + tastyArgs = + "--hide-successes" + : case opts.tastyPattern of + Just tastyPattern -> ["--pattern", tastyPattern] + Nothing -> [] + + when opts.listSteps $ do + -- TODO: This should probably list _all_ available steps, not just the selected ones! + tPutStrLn "Targets:" + forM_ targets $ \target -> do + tPutStrLn $ " " <> target + tPutStrLn "Steps:" + forM_ steps $ \step -> do + tPutStrLn $ " " <> displayStep step + exitSuccess + + startTime <- getAbsoluteTime + jobs <- maybe getNumCapabilities pure opts.jobs + cwd <- getCurrentDirectory + compiler <- makeCompiler opts.compiler + + pure + ResolvedOpts + { verbose = opts.verbose + , jobs = jobs + , cwd = cwd + , startTime = startTime + , compiler = compiler + , extraCompilers = opts.extraCompilers + , cabal = opts.cabal + , archPath = archPath + , projectFile = projectFile + , hackageTests = opts.hackageTests + , tastyArgs = tastyArgs + , targets = targets + , steps = steps + } + +-- | Command-line options. +data Opts = Opts + { verbose :: Bool + , jobs :: Maybe Int + , compiler :: FilePath + , cabal :: FilePath + , extraCompilers :: [FilePath] + , tastyPattern :: Maybe Text + , doctest :: Bool + , steps :: [Step] + , listSteps :: Bool + , libOnly :: Bool + , runLibTests :: Bool + , runCliTests :: Bool + , runLibSuite :: Bool + , runCliSuite :: Bool + , solverBenchmarks :: Bool + , hackageTests :: 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" + -- TODO: For tests? Builds? + <> help "Use the given compiler instead of `ghc`" + <> value "ghc" + ) + <*> strOption + ( long "with-cabal" + -- TODO: For builds? + <> help "Use the given `cabal-install`" + <> value "cabal" + ) + <*> many + ( strOption + ( long "extra-hc" + <> help "Extra compilers to run the test suites with" + ) + ) + <*> 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 . T.pack)) + ( 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 -> Text +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 Text Step +nameToStep = + Map.fromList + [ (displayStep step, step) + | step <- [minBound .. maxBound] + ] + +parseStep :: Text -> 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 + tPutStrLn "" + +getTerminalWidth :: IO Int +getTerminalWidth = maybe 80 (.width) <$> size @Int + +printHeader :: Text -> IO () +printHeader title = do + columns <- getTerminalWidth + let left = 3 + right = columns - T.length title - left - 2 + header = + tSetSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + <> T.replicate left "═" + <> " " + <> title + <> " " + <> T.replicate right "═" + <> tSetSGRCode [Reset] + tPutStrLn header + +withTiming :: ResolvedOpts -> Text -> IO a -> IO a +withTiming opts title action = do + startTime <- getAbsoluteTime + + result <- + (Right <$> action) + `catch` (\procFailed -> pure (Left (procFailed :: ProcFailed))) + + endTime <- getAbsoluteTime + + let duration = diffAbsoluteTime endTime startTime + totalDuration = diffAbsoluteTime endTime opts.startTime + + case result of + Right inner -> do + tPutStrLn $ + tSetSGRCode [SetColor Foreground Vivid Green] + <> title + <> " finished after " + <> formatDiffTime duration + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> tSetSGRCode [Reset] + + pure inner + Left _procFailed -> do + tPutStrLn $ + tSetSGRCode [SetColor Foreground Vivid Red] + <> title + <> " failed after " + <> formatDiffTime duration + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> tSetSGRCode [Reset] + + -- TODO: `--keep-going` mode. + exitFailure + +-- TODO: Shell escaping +displayCommand :: Text -> [Text] -> Text +displayCommand command args = command <> " " <> T.unwords args + +timedCabalBin :: ResolvedOpts -> Text -> Text -> [Text] -> IO () +timedCabalBin opts package component args = do + command <- cabalListBin opts (package <> ":" <> component) + timedWithCwd + opts + (T.unpack package) + command + args + +timedWithCwd :: ResolvedOpts -> FilePath -> Text -> [Text] -> IO () +timedWithCwd opts cdPath command args = do + -- TODO: Use `pushd`? + cd cdPath + timed opts command args + cd opts.cwd + +timed :: ResolvedOpts -> Text -> [Text] -> IO () +timed opts command args = do + let prettyCommand = displayCommand command args + + startTime <- getAbsoluteTime + + -- TODO: Replace `$HOME` or `opts.cwd` for brevity? + tPutStrLn $ + tSetSGRCode [SetColor Foreground Vivid Blue] + <> "$ " + <> prettyCommand + <> tSetSGRCode [Reset] + + (exitCode, rawOutput) <- + if opts.verbose + then (\exitCode -> (exitCode, "")) <$> proc command args "" + else procStrict command args "" + + endTime <- getAbsoluteTime + + let duration = diffAbsoluteTime endTime startTime + totalDuration = diffAbsoluteTime endTime opts.startTime + + output = T.strip rawOutput + linesLimit = 50 + outputLines = T.lines output + hiddenLines = length outputLines - linesLimit + tailLines = drop hiddenLines outputLines + + case exitCode of + ExitSuccess -> do + unless opts.verbose $ do + if hiddenLines <= 0 + then tPutStrLn output + else + tPutStrLn $ + "(" + <> tShow hiddenLines + <> " lines hidden, use `--verbose` to show)\n" + <> "...\n" + <> T.unlines tailLines + + tPutStrLn $ + tSetSGRCode [SetColor Foreground Vivid Green] + <> "Finished after " + <> formatDiffTime duration + <> ": " + <> prettyCommand + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> tSetSGRCode [Reset] + ExitFailure exitCode' -> do + unless opts.verbose $ do + tPutStrLn output + + tPutStrLn $ + tSetSGRCode [SetColor Foreground Vivid Red] + <> "Failed with exit code " + <> tShow exitCode' + <> " after " + <> formatDiffTime duration + <> ": " + <> prettyCommand + <> "\nTotal time so far: " + <> formatDiffTime totalDuration + <> tSetSGRCode [Reset] + + throwIO + ProcFailed + { procCommand = command + , procArguments = args + , procExitCode = exitCode + } + +getAbsoluteTime :: IO AbsoluteTime +getAbsoluteTime = systemToTAITime <$> getSystemTime + +formatDiffTime :: DiffTime -> Text +formatDiffTime delta = + let minute = secondsToDiffTime 60 + hour = 60 * minute + in T.pack $ + 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_ opts.steps $ \step -> do + runStep opts step + +printConfig :: ResolvedOpts -> IO () +printConfig opts = do + tPutStrLn $ + "compiler: " + <> T.pack opts.compiler.executable + <> "\ncabal-install: " + <> T.pack opts.cabal + <> "\njobs: " + <> tShow opts.jobs + <> "\nsteps: " + <> T.unwords (map displayStep opts.steps) + <> "\nHackage tests: " + <> tShow opts.hackageTests + <> "\nverbose: " + <> tShow opts.verbose + <> "\nextra compilers: " + <> T.pack (unwords opts.extraCompilers) + <> "\nextra RTS options: " + <> T.unwords (rtsArgs opts) + +printToolVersions :: ResolvedOpts -> IO () +printToolVersions opts = do + timed opts (T.pack opts.compiler.executable) ["--version"] + timed opts (T.pack opts.cabal) ["--version"] + + forM_ opts.extraCompilers $ \compiler -> do + timed opts (T.pack compiler) ["--version"] + +build :: ResolvedOpts -> IO () +build opts = do + printHeader "build (dry run)" + timed + opts + (T.pack opts.cabal) + ( cabalNewBuildArgs opts + ++ opts.targets + ++ ["--dry-run"] + ) + + printHeader "build (full build plan; cached and to-be-built dependencies)" + timed + opts + "jq" + [ "-r" + , -- TODO: Aeson...? Or even just make this a Cabal feature! + ".\"install-plan\" | map(.\"pkg-name\" + \"-\" + .\"pkg-version\" + \" \" + .\"component-name\") | join(\"\n\")" + , T.pack (baseBuildDir opts "cache" "plan.json") + ] + + printHeader "build (actual build)" + timed + opts + (T.pack opts.cabal) + (cabalNewBuildArgs opts ++ opts.targets) + +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) + ( opts.tastyArgs + ++ jobsArgs opts + ++ extraArgs + ) + + runCabalTests suite = runCabalTests' suite [] + + runCabalTests' "unit-tests" ["--with-ghc=" <> T.pack opts.compiler.executable] + runCabalTests "check-tests" + runCabalTests "parser-tests" + runCabalTests "rpmvercmp" + runCabalTests "no-thunks-test" + + hackageTests opts + +hackageTests :: ResolvedOpts -> IO () +hackageTests opts + | NoHackageTests <- opts.hackageTests = 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 opts.hackageTests of + CompleteHackageTests -> do + hackageTest ["parsec"] + hackageTest ["roundtrip"] + PartialHackageTests -> do + hackageTest ["parsec", "d"] + hackageTest ["roundtrip", "k"] + +libSuiteWith :: ResolvedOpts -> FilePath -> [Text] -> IO () +libSuiteWith opts ghc extraArgs = + timedCabalBin + opts + "cabal-testsuite" + "exe:cabal-tests" + ( [ "--builddir=" <> T.pack (cabalTestsuiteBuildDir opts) + , "--with-ghc=" <> T.pack ghc + , -- This test suite does not support `--jobs` _or_ `--num-threads`! + "-j" <> tShow opts.jobs + ] + ++ opts.tastyArgs + ++ extraArgs + ) + +libSuite :: ResolvedOpts -> IO () +libSuite opts = libSuiteWith opts opts.compiler.executable (rtsArgs opts) + +libSuiteExtras :: ResolvedOpts -> IO () +libSuiteExtras opts = forM_ opts.extraCompilers $ \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 + ++ opts.tastyArgs + ) + + -- This doesn't work in parallel either. + timedCabalBin + opts + "cabal-install" + "test:unit-tests" + ( ["--num-threads", "1"] + ++ opts.tastyArgs + ) + + -- Only single job, otherwise we fail with "Heap exhausted" + timedCabalBin + opts + "cabal-install" + "test:mem-use-tests" + ( ["--num-threads", "1"] + ++ opts.tastyArgs + ) + + -- This test-suite doesn't like concurrency + timedCabalBin + opts + "cabal-install" + "test:integration-tests2" + ( [ "--num-threads" + , "1" + , "--with-ghc=" <> T.pack opts.compiler.executable + ] + ++ opts.tastyArgs + ) + +cliSuite :: ResolvedOpts -> IO () +cliSuite opts = do + cabal <- cabalListBin opts "cabal-install:exe:cabal" + + timedCabalBin + opts + "cabal-testsuite" + "exe:cabal-tests" + ( [ "--builddir=" <> T.pack (cabalTestsuiteBuildDir opts) + , "--with-cabal=" <> cabal + , "--with-ghc=" <> T.pack opts.compiler.executable + , "--intree-cabal-lib=" <> T.pack opts.cwd + , "--test-tmp=" <> T.pack (opts.cwd "testdb") + ] + ++ jobsArgs opts + ++ opts.tastyArgs + ++ 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=" <> T.pack opts.cabal + , "--cabal2=" <> cabal + , "--trials=5" + , "--packages=Chart-diagrams" + , "--print-trials" + ] + +timeSummary :: ResolvedOpts -> IO () +timeSummary opts = do + endTime <- getAbsoluteTime + let totalDuration = diffAbsoluteTime endTime opts.startTime + tPutStrLn $ + tSetSGRCode [SetConsoleIntensity BoldIntensity, SetColor Foreground Vivid Cyan] + <> "!!! Validation completed in " + <> formatDiffTime totalDuration + <> tSetSGRCode [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 fc8586a3778..f7cfa1034b4 100755 --- a/validate.sh +++ b/validate.sh @@ -1,545 +1,3 @@ -#!/bin/sh -# shellcheck disable=SC2086 +#!/usr/bin/env bash -# 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=4 -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 -####################################################################### - -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 <