diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2003-2022, Cabal Development Team. +Copyright (c) 2003-2023, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,7 +1,7 @@ Cabal-Version: 2.2 Name: cabal-install -Version: 3.8.1.0 +Version: 3.10.1.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -13,7 +13,7 @@ License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team -Copyright: 2003-2022, Cabal Development Team +Copyright: 2003-2023, Cabal Development Team Category: Distribution Build-type: Simple Extra-Source-Files: @@ -46,20 +46,21 @@ ghc-options: -Wunused-packages common base-dep - build-depends: base >=4.10 && <4.17 + build-depends: base >=4.10 && <4.18 common cabal-dep - build-depends: Cabal ^>=3.8 + build-depends: Cabal ^>=3.10 common cabal-syntax-dep - build-depends: Cabal-syntax ^>=3.8 + build-depends: Cabal-syntax ^>=3.10 common cabal-install-solver-dep - build-depends: cabal-install-solver ^>=3.8 + build-depends: cabal-install-solver ^>=3.10 library import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep default-language: Haskell2010 + default-extensions: TypeOperators hs-source-dirs: src exposed-modules: @@ -83,6 +84,7 @@ Distribution.Client.CmdExec Distribution.Client.CmdFreeze Distribution.Client.CmdHaddock + Distribution.Client.CmdHaddockProject Distribution.Client.CmdInstall Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdInstall.ClientInstallTargetSelector @@ -98,7 +100,6 @@ Distribution.Client.Compat.ExecutablePath Distribution.Client.Compat.Orphans Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process Distribution.Client.Compat.Semaphore Distribution.Client.Config Distribution.Client.Configure @@ -166,6 +167,7 @@ Distribution.Client.Security.HTTP Distribution.Client.Setup Distribution.Client.SetupWrapper + Distribution.Client.Signal Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles Distribution.Client.SrcDist @@ -206,24 +208,24 @@ bytestring >= 0.10.6.0 && < 0.12, containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, - directory >= 1.2.2.0 && < 1.4, + directory >= 1.3.7.0 && < 1.4, echo >= 0.1.3 && < 0.2, edit-distance >= 0.2.2 && < 0.3, exceptions >= 0.10.4 && < 0.11, filepath >= 1.4.0.0 && < 1.5, hashable >= 1.0 && < 1.5, HTTP >= 4000.1.5 && < 4000.5, - mtl >= 2.0 && < 2.3, + mtl >= 2.0 && < 2.4, network-uri >= 2.6.0.2 && < 2.7, pretty >= 1.1 && < 1.2, process >= 1.2.3.0 && < 1.7, random >= 1.2 && < 1.3, stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, - time >= 1.5.0.1 && < 1.12, + time >= 1.5.0.1 && < 1.13, zlib >= 0.5.3 && < 0.7, hackage-security >= 0.6.2.0 && < 0.7, - text >= 1.2.3 && < 1.3, + text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.1, parsec >= 3.1.13.0 && < 3.2, regex-base >= 0.94.0.0 && <0.95, regex-posix >= 0.96.0.0 && <0.97, @@ -244,7 +246,11 @@ if flag(lukko) build-depends: lukko >= 0.1 && <0.2 + -- pull in process version with fixed waitForProcess error + if impl(ghc >=8.2) + build-depends: process >= 1.6.15.0 + executable cabal import: warnings, base-dep, cabal-dep, cabal-syntax-dep main-is: Main.hs @@ -267,6 +273,7 @@ test-suite unit-tests import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep default-language: Haskell2010 + default-extensions: TypeOperators ghc-options: -rtsopts -threaded type: exitcode-stdio-1.0 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,8 @@ -*-change-log-*- +3.10.1.0 Mikolaj Konarski March 2023 + * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.1.0.md + 3.8.1.0 Mikolaj Konarski August 2022 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.8.1.0.md @@ -169,7 +172,7 @@ * Default changelog generated by 'cabal init' is now named 'CHANGELOG.md' (#5441). * Align output of 'new-build' command phases (#4040). - * Add suport for specifying remote VCS dependencies via new + * Add support for specifying remote VCS dependencies via new 'source-repository-package' stanzas in 'cabal.project' files (#5351). @@ -206,7 +209,7 @@ * Use [lfxtb] letters to differentiate component kind instead of opaque "c" in dist-dir layout. * 'cabal configure' now supports '--enable-static', which can be - used to build static libaries with GHC via GHC's `-staticlib` + used to build static libraries with GHC via GHC's `-staticlib` flag. * 'cabal user-config now supports '--augment' which can append additional lines to a new or updated cabal config file. @@ -226,7 +229,7 @@ when it wasn't necessary (#4444). * Packages installed in sandboxes via 'add-source' now have their timestamps updated correctly and so will not be reinstalled - unncecessarily if the main install command fails (#1375). + unnecessarily if the main install command fails (#1375). * Add Windows device path support for copyFile, renameFile. Allows cabal new-build to use temporary store path of up to 32k length (#3972, #4914, #4515). @@ -577,9 +580,9 @@ * Improved bootstrap.sh 0.5.2 Duncan Coutts Aug 2008 - * Suport building haddock documentaion + * Support building haddock documentation * Self-reinstall now works on Windows - * Allow adding symlinks to excutables into a separate bindir + * Allow adding symlinks to executables into a separate bindir * New self-documenting config file * New install --reinstall flag * More helpful status messages in a couple places diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | @@ -78,6 +80,7 @@ import qualified Distribution.Client.CmdRepl as CmdRepl import qualified Distribution.Client.CmdFreeze as CmdFreeze import qualified Distribution.Client.CmdHaddock as CmdHaddock +import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject import qualified Distribution.Client.CmdInstall as CmdInstall import qualified Distribution.Client.CmdRun as CmdRun import qualified Distribution.Client.CmdTest as CmdTest @@ -113,6 +116,8 @@ import Distribution.Client.ManpageFlags (ManpageFlags (..)) import Distribution.Client.Utils ( determineNumJobs, relaxEncodingErrors ) +import Distribution.Client.Signal + ( installTerminationHandler ) import Distribution.Client.Version ( cabalInstallVersion ) @@ -159,20 +164,22 @@ import System.FilePath ( dropExtension, splitExtension , takeExtension, (), (<.>) ) import System.IO ( BufferMode(LineBuffering), hSetBuffering - , stderr, stdout ) + , hPutStrLn, stderr, stdout ) import System.Directory ( doesFileExist, getCurrentDirectory , withCurrentDirectory) import Data.Monoid (Any(..)) -import Control.Exception (try) +import Control.Exception (AssertionFailed, assert, try) -- | Entry point -- main :: IO () main = do + installTerminationHandler -- Enable line buffering so that we can get fast feedback even when piped. -- This is especially important for CI and build systems. hSetBuffering stdout LineBuffering + -- If the locale encoding for CLI doesn't support all Unicode characters, -- printing to it may fail unless we relax the handling of encoding errors -- when writing to stderr and stdout. @@ -181,12 +188,20 @@ (args0, args1) <- break (== "--") <$> getArgs mainWorker =<< (++ args1) <$> expandResponse args0 +-- | Check whether assertions are enabled and print a warning in that case. +warnIfAssertionsAreEnabled :: IO () +warnIfAssertionsAreEnabled = + assert False (return ()) `catch` + (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg) + -- Andreas, 2022-12-30, issue #8654: + -- The verbosity machinery is not in place at this point (option -v not parsed), + -- so instead of using function @warn@, we print straight to stderr. + where + assertionsEnabledMsg = + "Warning: this is a debug build of cabal-install with assertions enabled." + mainWorker :: [String] -> IO () mainWorker args = do - maybeScriptAndArgs <- case args of - [] -> return Nothing - (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h - topHandler $ case commandsRun (globalCommand commands) commands args of CommandHelp help -> printGlobalHelp help @@ -200,10 +215,23 @@ -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts - CommandErrors errs -> maybe (printErrors errs) go maybeScriptAndArgs where - go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs - CommandReadyToGo action -> action globalFlags + CommandErrors errs -> do + -- Check whether cabal is called from a script, like #!/path/to/cabal. + case args of + [] -> printErrors errs + script : scriptArgs -> CmdRun.validScript script >>= \case + False -> printErrors errs + True -> do + -- In main operation (not help, version etc.) print warning if assertions are on. + warnIfAssertionsAreEnabled + CmdRun.handleShebang script scriptArgs + + CommandReadyToGo action -> do + -- In main operation (not help, version etc.) print warning if assertions are on. + warnIfAssertionsAreEnabled + action globalFlags + where printCommandHelp help = do pname <- getProgName @@ -254,6 +282,8 @@ , newCmd CmdRepl.replCommand CmdRepl.replAction , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , newCmd CmdHaddockProject.haddockProjectCommand + CmdHaddockProject.haddockProjectAction , newCmd CmdInstall.installCommand CmdInstall.installAction , newCmd CmdRun.runCommand CmdRun.runAction , newCmd CmdTest.testCommand CmdTest.testAction @@ -409,7 +439,7 @@ buildNumJobs = NoFlag } buildFlags_latest = buildFlags { - -- Take the 'jobs' setting '~/.cabal/config' into account. + -- Take the 'jobs' setting config file into account. buildNumJobs = Flag . Just . determineNumJobs $ (numJobsConfigFlag `mappend` numJobsCmdLineFlag) } diff --git a/src/Distribution/Client/BuildReports/Anonymous.hs b/src/Distribution/Client/BuildReports/Anonymous.hs --- a/src/Distribution/Client/BuildReports/Anonymous.hs +++ b/src/Distribution/Client/BuildReports/Anonymous.hs @@ -37,7 +37,7 @@ import Distribution.Client.Version (cabalInstallVersion) import Distribution.Compiler (CompilerId (..)) import Distribution.FieldGrammar -import Distribution.Fields +import Distribution.Fields import Distribution.Package (PackageIdentifier (..), mkPackageName) import Distribution.PackageDescription (FlagAssignment) import Distribution.Parsec diff --git a/src/Distribution/Client/Check.hs b/src/Distribution/Client/Check.hs --- a/src/Distribution/Client/Check.hs +++ b/src/Distribution/Client/Check.hs @@ -26,7 +26,7 @@ import Distribution.PackageDescription.Configuration (flattenPackageDescription) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) -import Distribution.Parsec (PWarning (..), showPError, showPWarning) +import Distribution.Parsec (PWarning (..), showPError) import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) import System.IO (hPutStr, stderr) @@ -55,8 +55,7 @@ pdfile <- defaultPackageDesc verbosity (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile -- convert parse warnings into PackageChecks - -- Note: we /could/ pick different levels, based on warning type. - let ws' = [ PackageDistSuspicious (showPWarning pdfile w) | w <- ws ] + let ws' = map (wrapParseWarning pdfile) ws -- flatten the generic package description into a regular package -- description -- TODO: this may give more warnings than it should give; @@ -111,4 +110,6 @@ return (not . any isCheckError $ packageChecks) where - printCheckMessages = traverse_ (warn verbosity . explanation) + printCheckMessages :: [PackageCheck] -> IO () + printCheckMessages = traverse_ (warn verbosity) . map show + -- xxx mapM_ o traverse? diff --git a/src/Distribution/Client/CmdBench.hs b/src/Distribution/Client/CmdBench.hs --- a/src/Distribution/Client/CmdBench.hs +++ b/src/Distribution/Client/CmdBench.hs @@ -118,7 +118,7 @@ runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @bench@ command. diff --git a/src/Distribution/Client/CmdBuild.hs b/src/Distribution/Client/CmdBuild.hs --- a/src/Distribution/Client/CmdBuild.hs +++ b/src/Distribution/Client/CmdBuild.hs @@ -6,6 +6,9 @@ buildCommand, buildAction, + BuildFlags(..), + defaultBuildFlags, + -- * Internals exposed for testing selectPackageTargets, selectComponentTarget @@ -98,7 +101,7 @@ -- buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags - = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do + = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags <> buildOnlyConfigure buildFlags) diff --git a/src/Distribution/Client/CmdClean.hs b/src/Distribution/Client/CmdClean.hs --- a/src/Distribution/Client/CmdClean.hs +++ b/src/Distribution/Client/CmdClean.hs @@ -4,12 +4,12 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Client.Config + ( defaultScriptBuildsDir ) import Distribution.Client.DistDirLayout ( DistDirLayout(..), defaultDistDirLayout ) import Distribution.Client.ProjectConfig ( findProjectRoot ) -import Distribution.Client.ScriptUtils - ( getScriptCacheDirectoryRoot ) import Distribution.Client.Setup ( GlobalFlags ) import Distribution.ReadE ( succeedReadE ) @@ -121,7 +121,7 @@ -- There is currently no good way to specify to only clean orphaned caches. -- It would be better as part of an explicit gc step (see issue #3333) toClean <- Set.fromList <$> mapM canonicalizePath extraArgs - cacheDir <- getScriptCacheDirectoryRoot + cacheDir <- defaultScriptBuildsDir existsCD <- doesDirectoryExist cacheDir caches <- if existsCD then listDirectory cacheDir else return [] paths <- fmap concat . forM caches $ \cache -> do diff --git a/src/Distribution/Client/CmdErrorMessages.hs b/src/Distribution/Client/CmdErrorMessages.hs --- a/src/Distribution/Client/CmdErrorMessages.hs +++ b/src/Distribution/Client/CmdErrorMessages.hs @@ -72,6 +72,13 @@ renderListCommaAnd [x,x'] = x ++ " and " ++ x' renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs +renderListTabular :: [String] -> String +renderListTabular = ("\n"++) . unlines . map ("| * "++) + +renderListPretty :: [String] -> String +renderListPretty xs = if length xs > 5 then renderListTabular xs + else renderListCommaAnd xs + -- | Render a list of things in the style @blah blah; this that; and the other@ renderListSemiAnd :: [String] -> String renderListSemiAnd [] = "" diff --git a/src/Distribution/Client/CmdFreeze.hs b/src/Distribution/Client/CmdFreeze.hs --- a/src/Distribution/Client/CmdFreeze.hs +++ b/src/Distribution/Client/CmdFreeze.hs @@ -115,6 +115,7 @@ distDirLayout cabalDirLayout projectConfig localPackages + Nothing let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos dryRun = buildSettingDryRun buildSettings @@ -233,4 +234,3 @@ | InstallPlan.Configured elab <- InstallPlan.toList plan , elabLocalToProject elab ] - diff --git a/src/Distribution/Client/CmdHaddock.hs b/src/Distribution/Client/CmdHaddock.hs --- a/src/Distribution/Client/CmdHaddock.hs +++ b/src/Distribution/Client/CmdHaddock.hs @@ -7,6 +7,8 @@ haddockCommand, haddockAction, + ClientHaddockFlags(..), + -- * Internals exposed for testing selectPackageTargets, selectComponentTarget @@ -16,17 +18,23 @@ import Prelude () import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning + ( ElaboratedSharedConfig(..) ) import Distribution.Client.CmdErrorMessages import Distribution.Client.TargetProblem ( TargetProblem (..), TargetProblem' ) import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..) ) + ( GlobalFlags, ConfigFlags(..), InstallFlags (..)) import Distribution.Simple.Setup ( HaddockFlags(..), fromFlagOrDefault, trueArg ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives, ShowOrParseArgs, OptionField, option ) +import Distribution.Simple.Program.Builtin + ( haddockProgram ) +import Distribution.Simple.Program.Db + ( addKnownProgram, reconfigurePrograms ) import Distribution.Verbosity ( normal ) import Distribution.Simple.Utils @@ -118,11 +126,26 @@ printPlan verbosity baseCtx buildCtx - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + progs <- reconfigurePrograms verbosity + (haddockProgramPaths haddockFlags) + (haddockProgramArgs haddockFlags) + -- we need to insert 'haddockProgram' before we reconfigure it, + -- otherwise 'set + . addKnownProgram haddockProgram + . pkgConfigCompilerProgs + . elaboratedShared + $ buildCtx + let buildCtx' = buildCtx { elaboratedShared = + (elaboratedShared buildCtx) + { pkgConfigCompilerProgs = progs } } + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx' + runProjectPostBuildPhase verbosity baseCtx buildCtx' buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here + installDoc = fromFlagOrDefault True (installDocumentation installFlags) + flags' = flags { installFlags = installFlags { installDocumentation = Flag installDoc } } + cliConfig = commandLineFlagsToProjectConfig globalFlags flags' mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/src/Distribution/Client/CmdHaddockProject.hs b/src/Distribution/Client/CmdHaddockProject.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/CmdHaddockProject.hs @@ -0,0 +1,337 @@ +module Distribution.Client.CmdHaddockProject + ( haddockProjectCommand + , haddockProjectAction + ) where + +import Prelude () +import Data.Bool (bool) +import Distribution.Client.Compat.Prelude hiding (get) + +import qualified Distribution.Client.CmdBuild as CmdBuild +import qualified Distribution.Client.CmdHaddock as CmdHaddock + +import Distribution.Client.DistDirLayout (DistDirLayout(..) + ,CabalDirLayout(..) + ,StoreDirLayout(..)) +import Distribution.Client.InstallPlan (foldPlanPackage) +import qualified Distribution.Client.InstallPlan as InstallPlan +import qualified Distribution.Client.NixStyleOptions as NixStyleOptions +import Distribution.Client.ProjectOrchestration + (AvailableTarget(..) + ,AvailableTargetStatus(..) + ,CurrentCommand(..) + ,ProjectBaseContext(..) + ,ProjectBuildContext(..) + ,TargetSelector(..) + ,printPlan + ,pruneInstallPlanToTargets + ,resolveTargets + ,runProjectPreBuildPhase + ,selectComponentTargetBasic) +import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage(..) + ,ElaboratedInstallPlan + ,ElaboratedSharedConfig(..) + ,TargetAction(..)) +import Distribution.Client.ProjectPlanning.Types + (elabDistDirParams) +import Distribution.Client.Setup (GlobalFlags(..) + ,ConfigFlags(..)) +import Distribution.Client.ScriptUtils (AcceptNoTargets(..) + ,TargetContext(..) + ,updateContextAndWriteProjectFile + ,withContextAndSelectors) +import Distribution.Client.TargetProblem (TargetProblem(..)) + +import Distribution.Types.PackageId (pkgName) +import Distribution.Types.PackageName (unPackageName) +import Distribution.Types.Version (mkVersion) +import Distribution.Types.VersionRange (orLaterVersion) +import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..)) +import Distribution.Simple.Command + ( CommandUI(..) ) +import Distribution.Simple.Compiler + ( Compiler (..) ) +import Distribution.Simple.Flag + ( Flag(..) + , flagElim + , flagToList + , fromFlag + , fromFlagOrDefault + ) +import Distribution.Simple.InstallDirs + ( toPathTemplate ) +import Distribution.Simple.Haddock (createHaddockIndex) +import Distribution.Simple.Utils + ( die', createDirectoryIfMissingVerbose + , copyDirectoryRecursive, warn ) +import Distribution.Simple.Program.Builtin + ( haddockProgram ) +import Distribution.Simple.Program.Db + ( addKnownProgram, reconfigurePrograms, requireProgramVersion ) +import Distribution.Simple.Setup + ( HaddockFlags(..), defaultHaddockFlags + , HaddockProjectFlags(..) + , Visibility(..) + , haddockProjectCommand + ) +import Distribution.Verbosity as Verbosity + ( normal ) + +import System.FilePath ( takeDirectory, normalise, (), (<.>) ) +import System.Directory ( doesDirectoryExist, doesFileExist ) + +haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO () +haddockProjectAction flags _extraArgs globalFlags = do + -- create destination directory if it does not exist + let outputDir = normalise $ fromFlag (haddockProjectDir flags) + createDirectoryIfMissingVerbose verbosity True outputDir + + when ((2::Int) <= + ( flagElim 0 (bool 0 1) (haddockProjectHackage flags) + + flagElim 0 (bool 0 1) (haddockProjectLocal flags) + + flagElim 0 (const 1) (haddockProjectHtmlLocation flags) + )) $ + die' verbosity "Options `--local`, `--hackage` and `--html-location` are mutually exclusive`" + + warn verbosity "haddock-project command is experimental, it might break in the future" + + -- build all packages with appropriate haddock flags + let haddockFlags = defaultHaddockFlags + { haddockHtml = Flag True + -- one can either use `--haddock-base-url` or + -- `--haddock-html-location`. + , haddockBaseUrl = if localStyle + then Flag ".." + else NoFlag + , haddockProgramPaths = haddockProjectProgramPaths flags + , haddockProgramArgs = haddockProjectProgramArgs flags + , haddockHtmlLocation = if fromFlagOrDefault False (haddockProjectHackage flags) + then Flag "https://hackage.haskell.org/package/$pkg-$version/docs" + else haddockProjectHtmlLocation flags + , haddockHoogle = haddockProjectHoogle flags + , haddockExecutables = haddockProjectExecutables flags + , haddockTestSuites = haddockProjectTestSuites flags + , haddockBenchmarks = haddockProjectBenchmarks flags + , haddockForeignLibs = haddockProjectForeignLibs flags + , haddockInternal = haddockProjectInternal flags + , haddockCss = haddockProjectCss flags + , haddockLinkedSource = if localOrHackage + then Flag True + else haddockProjectLinkedSource flags + , haddockQuickJump = if localOrHackage + then Flag True + else haddockProjectQuickJump flags + , haddockHscolourCss = haddockProjectHscolourCss flags + , haddockContents = if localStyle then Flag (toPathTemplate "../index.html") + else NoFlag + , haddockIndex = if localStyle then Flag (toPathTemplate "../doc-index.html") + else NoFlag + , haddockKeepTempFiles= haddockProjectKeepTempFiles flags + , haddockVerbosity = haddockProjectVerbosity flags + , haddockLib = haddockProjectLib flags + } + nixFlags = (commandDefaultFlags CmdHaddock.haddockCommand) + { NixStyleOptions.haddockFlags = haddockFlags + , NixStyleOptions.configFlags = + (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand)) + { configVerbosity = haddockProjectVerbosity flags } + } + + -- + -- Construct the build plan and infer the list of packages which haddocks + -- we need. + -- + + withContextAndSelectors RejectNoTargets Nothing nixFlags ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> return ctx + ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta + let distLayout = distDirLayout baseCtx + cabalLayout = cabalDirLayout baseCtx + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- either reportTargetProblems return + $ resolveTargets + selectPackageTargets + selectComponentTargetBasic + elaboratedPlan + Nothing + targetSelectors + + let elaboratedPlan' = pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + printPlan verbosity baseCtx buildCtx + + let elaboratedPlan :: ElaboratedInstallPlan + elaboratedPlan = elaboratedPlanOriginal buildCtx + + sharedConfig :: ElaboratedSharedConfig + sharedConfig = elaboratedShared buildCtx + + pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage ] + pkgs = matchingPackages elaboratedPlan + + progs <- reconfigurePrograms verbosity + (haddockProjectProgramPaths flags) + (haddockProjectProgramArgs flags) + -- we need to insert 'haddockProgram' before we reconfigure it, + -- otherwise 'set + . addKnownProgram haddockProgram + . pkgConfigCompilerProgs + $ sharedConfig + let sharedConfig' = sharedConfig { pkgConfigCompilerProgs = progs } + + _ <- requireProgramVersion + verbosity haddockProgram + (orLaterVersion (mkVersion [2,26,1])) progs + + -- + -- Build haddocks of each components + -- + + CmdHaddock.haddockAction + nixFlags + ["all"] + globalFlags + + -- + -- Copy haddocks to the destination folder + -- + + packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg -> + case pkg of + Left _ | not localStyle -> + return [] + Left package -> do + let packageName = unPackageName (pkgName $ sourcePackageId package) + destDir = outputDir packageName + fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do + let docDir = takeDirectory interfacePath + a <- doesFileExist interfacePath + case a of + True -> copyDirectoryRecursive verbosity docDir destDir + >> return (Just ( packageName + , interfacePath + , Hidden + )) + False -> return Nothing + + Right package -> + case elabLocalToProject package of + True -> do + let distDirParams = elabDistDirParams sharedConfig' package + buildDir = distBuildDirectory distLayout distDirParams + packageName = unPackageName (pkgName $ elabPkgSourceId package) + let docDir = buildDir + "doc" "html" + packageName + destDir = outputDir packageName + interfacePath = destDir + packageName <.> "haddock" + a <- doesDirectoryExist docDir + case a of + True -> copyDirectoryRecursive verbosity docDir destDir + >> return [( packageName + , interfacePath + , Visible + )] + False -> return [] + False | not localStyle -> + return [] + False -> do + let packageName = unPackageName (pkgName $ elabPkgSourceId package) + packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout) + (compilerId (pkgConfigCompiler sharedConfig')) + (elabUnitId package) + docDir = packageDir "share" "doc" "html" + destDir = outputDir packageName + interfacePath = destDir + packageName <.> "haddock" + a <- doesDirectoryExist docDir + case a of + True -> copyDirectoryRecursive verbosity docDir destDir + -- non local packages will be hidden in haddock's + -- generated contents page + >> return [( packageName + , interfacePath + , Hidden + )] + False -> return [] + + -- + -- generate index, content, etc. + -- + + let flags' = flags + { haddockProjectDir = Flag outputDir + , haddockProjectGenIndex = if localOrHackage + then Flag True + else haddockProjectGenIndex flags + , haddockProjectGenContents = if localOrHackage + then Flag True + else haddockProjectGenContents flags + , haddockProjectQuickJump = if localOrHackage + then Flag True + else haddockProjectQuickJump flags + , haddockProjectLinkedSource = haddockLinkedSource haddockFlags + , haddockProjectInterfaces = Flag + [ ( interfacePath + , Just packageName + , Just packageName + , visibility + ) + | (packageName, interfacePath, visibility) <- packageInfos + ] + } + createHaddockIndex verbosity + (pkgConfigCompilerProgs sharedConfig') + (pkgConfigCompiler sharedConfig') + (pkgConfigPlatform sharedConfig') + flags' + where + verbosity = fromFlagOrDefault normal (haddockProjectVerbosity flags) + + -- Build a self contained directory which contains haddocks of all + -- transitive dependencies; or depend on `--haddocks-html-location` to + -- provide location of the documentation of dependencies. + localStyle = + let local = fromFlagOrDefault False (haddockProjectLocal flags) + hackage = fromFlagOrDefault False (haddockProjectHackage flags) + location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags) + in local && not hackage && not location + -- or if none of the flags is given set `localStyle` to `True` + || not local && not hackage && not location + + + localOrHackage = + any id $ flagToList (haddockProjectLocal flags) + ++ flagToList (haddockProjectHackage flags) + + reportTargetProblems :: Show x => [x] -> IO a + reportTargetProblems = + die' verbosity . unlines . map show + + -- TODO: this is just a sketch + selectPackageTargets :: TargetSelector + -> [AvailableTarget k] + -> Either (TargetProblem ()) [k] + selectPackageTargets _ ts = Right $ + mapMaybe + (\t -> case availableTargetStatus t of + TargetBuildable k _ | availableTargetLocalToProject t + -> Just k + _ -> Nothing) + ts + + matchingPackages :: ElaboratedInstallPlan + -> [Either InstalledPackageInfo ElaboratedConfiguredPackage] + matchingPackages = + fmap (foldPlanPackage Left Right) + . InstallPlan.toList diff --git a/src/Distribution/Client/CmdInstall.hs b/src/Distribution/Client/CmdInstall.hs --- a/src/Distribution/Client/CmdInstall.hs +++ b/src/Distribution/Client/CmdInstall.hs @@ -33,7 +33,7 @@ import Distribution.Client.CmdInstall.ClientInstallTargetSelector import Distribution.Client.Setup - ( GlobalFlags(..), ConfigFlags(..) ) + ( GlobalFlags(..), ConfigFlags(..), InstallFlags(..) ) import Distribution.Client.Types ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage , SourcePackageDb(..) ) @@ -53,18 +53,19 @@ import Distribution.Client.ProjectConfig.Types ( ProjectConfig(..), ProjectConfigShared(..) , ProjectConfigBuildOnly(..), PackageConfig(..) + , MapMappend(..) , getMapLast, getMapMappend, projectConfigLogsDir , projectConfigStoreDir, projectConfigBuildOnly , projectConfigConfigFile ) import Distribution.Simple.Program.Db ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb - , modifyProgramSearchPath, ProgramDb ) + , modifyProgramSearchPath ) import Distribution.Simple.BuildPaths ( exeExtension ) import Distribution.Simple.Program.Find ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config - ( defaultInstallPath, getCabalDir, loadConfig, SavedConfig(..) ) + ( defaultInstallPath, loadConfig, SavedConfig(..) ) import qualified Distribution.Simple.PackageIndex as PI import Distribution.Solver.Types.PackageIndex ( lookupPackageName, searchByName ) @@ -96,11 +97,11 @@ import Distribution.Simple.Flag ( fromFlagOrDefault, flagToMaybe, flagElim ) import Distribution.Simple.Setup - ( Flag(..) ) + ( Flag(..), installDirsOptions ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI(..), usageAlternatives, optionName ) import Distribution.Simple.Configure ( configCompilerEx ) import Distribution.Simple.Compiler @@ -124,12 +125,11 @@ , withTempDirectory, createDirectoryIfMissingVerbose , ordNub ) import Distribution.Utils.Generic - ( safeHead, writeFileAtomic ) + ( writeFileAtomic ) import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Ord - ( Down(..) ) import qualified Data.Map as Map +import qualified Data.Set as S import qualified Data.List.NonEmpty as NE import Distribution.Utils.NubList ( fromNubList ) @@ -150,7 +150,7 @@ , commandDescription = Just $ \_ -> wrapText $ "Installs one or more packages. This is done by installing them " ++ "in the store and symlinking/copying the executables in the directory " - ++ "specified by the --installdir flag (`~/.cabal/bin/` by default). " + ++ "specified by the --installdir flag (`~/.local/bin/` by default). " ++ "If you want the installed executables to be available globally, " ++ "make sure that the PATH environment variable contains that directory. " ++ "\n\n" @@ -168,10 +168,15 @@ ++ " " ++ pname ++ " v2-install ./pkgfoo\n" ++ " Install the package in the ./pkgfoo directory\n" - , commandOptions = nixStyleOptions clientInstallOptions + , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags } + where + -- install doesn't take installDirs flags, since it always installs into the store in a fixed way. + notInstallDirOpt x = not $ optionName x `elem` installDirOptNames + installDirOptNames = map optionName installDirsOptions + -- | The @install@ command actually serves four different needs. It installs: -- * exes: -- For example a program from hackage. The behavior is similar to the old @@ -204,6 +209,15 @@ targetFilter = if installLibs then Just LibKind else Just ExeKind targetStrings' = if null targetStrings then ["."] else targetStrings + -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris. + -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where + -- no project file is present (including an implicit one derived from being in a package directory) + -- or where the --ignore-project flag is passed explicitly. In such a case we only parse colon-free target selectors + -- as selectors, and otherwise parse things as URIs. + + -- However, in the special case where --ignore-project is passed with no selectors, we want to act as though this is + -- a "normal" ignore project that actually builds and installs the selected package. + withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) withProject = do let reducedVerbosity = lessVerbose verbosity @@ -233,7 +247,7 @@ packageTargets = flip TargetPackageNamed targetFilter . pkgName <$> packageIds - if null targetStrings' + if null targetStrings'' -- if every selector is already resolved as a packageid, return without further parsing. then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx) else do targetSelectors <- @@ -250,11 +264,10 @@ , selectors ++ packageTargets , projectConfig localBaseCtx ) - withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig) + withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) + withoutProject _ | null targetStrings = withProject -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir withoutProject globalConfig = do tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings' - - cabalDir <- getCabalDir let projectConfig = globalConfig <> cliConfig @@ -268,8 +281,9 @@ mlogsDir = flagToMaybe projectConfigLogsDir mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir + let buildSettings = resolveBuildTimeSettings verbosity cabalDirLayout projectConfig @@ -363,14 +377,37 @@ (projectConfigBuildOnly config) [ ProjectPackageRemoteTarball uri | uri <- uris ] + -- check for targets already in env + let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName + getPackageName (NamedPackage pn _) = pn + getPackageName (SpecificSourcePackage (SourcePackage pkgId _ _ _)) = pkgName pkgId + targetNames = S.fromList $ map getPackageName (specs ++ uriSpecs) + envNames = S.fromList $ map getPackageName envSpecs + forceInstall = fromFlagOrDefault False $ installOverrideReinstall installFlags + nameIntersection = S.intersection targetNames envNames + + -- we check for intersections in targets with the existing env + (envSpecs', nonGlobalEnvEntries') <- if null nameIntersection + then pure (envSpecs, map snd nonGlobalEnvEntries) + else if forceInstall + then let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs + nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries + in pure (es, nge) + else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection) + + -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that we can solve with regards to packages installed locally but not in the upstream repo + let installedPacks = PI.allPackagesByName installedIndex + newEnvNames = S.fromList $ map getPackageName envSpecs' + installedIndex' = PI.fromList . concatMap snd . filter (\p -> fst p `S.member` newEnvNames) $ installedPacks + baseCtx <- establishDummyProjectBaseContext verbosity config distDirLayout - (envSpecs ++ specs ++ uriSpecs) + (envSpecs' ++ specs ++ uriSpecs) InstallCommand - buildCtx <- constructProjectBuildContext verbosity baseCtx targetSelectors + buildCtx <- constructProjectBuildContext verbosity (baseCtx {installedPackages = Just installedIndex'}) targetSelectors printPlan verbosity baseCtx buildCtx @@ -387,19 +424,31 @@ unless dryRun $ if installLibs then installLibraries verbosity - buildCtx compiler packageDbs progDb envFile nonGlobalEnvEntries + buildCtx compiler packageDbs envFile nonGlobalEnvEntries' else installExes verbosity baseCtx buildCtx platform compiler configFlags clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') ignoreProject = flagIgnoreProject projectFlags - cliConfig = commandLineFlagsToProjectConfig - globalFlags - flags { configFlags = configFlags' } - clientInstallFlags' + baseCliConfig = commandLineFlagsToProjectConfig + globalFlags + flags { configFlags = configFlags' } + clientInstallFlags' + cliConfig = addLocalConfigToTargets baseCliConfig targetStrings globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) +-- | Treat all direct targets of install command as local packages: #8637 +addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig +addLocalConfigToTargets config targetStrings + = config { + projectConfigSpecificPackage = projectConfigSpecificPackage config + <> MapMappend (Map.fromList targetPackageConfigs) + } + where + localConfig = projectConfigLocalPackages config + targetPackageConfigs = map (\x -> (mkPackageName x, localConfig)) targetStrings + -- | Verify that invalid config options were not passed to the install command. -- -- If an invalid configuration is found the command will @die'@. @@ -605,7 +654,7 @@ installdir <- fromFlagOrDefault (warn verbosity installdirUnknown >> pure installPath) $ pure <$> cinstInstalldir clientInstallFlags - createDirectoryIfMissingVerbose verbosity False installdir + createDirectoryIfMissingVerbose verbosity True installdir warnIfNoExes verbosity buildCtx installMethod <- flagElim defaultMethod return $ @@ -640,29 +689,18 @@ -> ProjectBuildContext -> Compiler -> PackageDBStack - -> ProgramDb -> FilePath -- ^ Environment file -> [GhcEnvironmentFileEntry] -> IO () installLibraries verbosity buildCtx compiler - packageDbs programDb envFile envEntries = do - -- Why do we get it again? If we updated a globalPackage then we need - -- the new version. - installedIndex <- getInstalledPackages verbosity compiler packageDbs programDb + packageDbs envFile envEntries = do if supportsPkgEnvFiles $ getImplInfo compiler then do let - getLatest :: PackageName -> [InstalledPackageInfo] - getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) - . PI.lookupPackageName installedIndex - globalLatest = concat (getLatest <$> globalPackages) - baseEntries = GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs - globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest pkgEntries = ordNub $ - globalEntries - ++ envEntries + envEntries ++ entriesForLibraryComponents (targetsMap buildCtx) contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) createDirectoryIfMissing True (takeDirectory envFile) @@ -700,21 +738,12 @@ exeMaybe (ComponentTarget (CExeName exe) _) = Just exe exeMaybe _ = Nothing -globalPackages :: [PackageName] -globalPackages = mkPackageName <$> - [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" - , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary" - , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq" - , "ghc-boot-th", "pretty", "template-haskell", "directory", "text" - , "bin-package-db" - ] - -- | Return the package specifiers and non-global environment file entries. getEnvSpecsAndNonGlobalEntries :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] -> Bool - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) + -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)]) getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs = if installLibs then (envSpecs, envEntries') @@ -724,7 +753,7 @@ environmentFileToSpecifiers :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry] - -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) + -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)]) environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId) | Just InstalledPackageInfo @@ -732,9 +761,7 @@ <- PI.lookupUnitId ipi unitId , let pkgSpec = NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] - -> if pkgName `elem` globalPackages - then ([pkgSpec], []) - else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) + -> ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)]) _ -> ([], []) @@ -912,11 +939,10 @@ -> Flag FilePath -> IO PackageDBStack getPackageDbStack compilerId storeDirFlag logsDirFlag = do - cabalDir <- getCabalDir mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag let mlogsDir = flagToMaybe logsDirFlag - cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId -- | This defines what a 'TargetSelector' means for the @bench@ command. diff --git a/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs --- a/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs +++ b/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs @@ -66,7 +66,7 @@ "How to handle already existing symlinks." cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v }) $ reqArg "always|never|prompt" - (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) + (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) (map prettyShow . flagToList) , option [] ["install-method"] "How to install the executables." diff --git a/src/Distribution/Client/CmdListBin.hs b/src/Distribution/Client/CmdListBin.hs --- a/src/Distribution/Client/CmdListBin.hs +++ b/src/Distribution/Client/CmdListBin.hs @@ -34,7 +34,7 @@ import Distribution.Simple.BuildPaths (dllExtension, exeExtension) import Distribution.Simple.Command (CommandUI (..)) import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault) -import Distribution.Simple.Utils (die', wrapText) +import Distribution.Simple.Utils (die', withOutputMarker, wrapText) import Distribution.System (Platform) import Distribution.Types.ComponentName (showComponentName) import Distribution.Types.UnitId (UnitId) @@ -78,7 +78,7 @@ _ -> die' verbosity "One target is required, given multiple" -- configure and elaborate target selectors - withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags $ \targetCtx ctx targetSelectors -> do + withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do baseCtx <- case targetCtx of ProjectContext -> return ctx GlobalContext -> return ctx @@ -133,7 +133,18 @@ case binfiles of [] -> die' verbosity "No target found" - [exe] -> putStrLn exe + [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n" + -- Andreas, 2023-01-13, issue #8400: + -- Regular output of `list-bin` should go to stdout unconditionally, + -- but for the sake of the testsuite, we want to mark it so it goes + -- into the golden value for the test. + -- Note: 'withOutputMarker' only checks 'isVerboseMarkOutput', + -- thus, we can reuse @verbosity@ here, even if other components + -- of @verbosity@ may be wrong (like 'VStderr', verbosity level etc.). + -- Andreas, 2023-01-20: + -- Appending the newline character here rather than using 'putStrLn' + -- because an active 'withOutputMarker' produces text that ends + -- in newline characters. _ -> die' verbosity "Multiple targets found" where defaultVerbosity = verboseStderr silent diff --git a/src/Distribution/Client/CmdOutdated.hs b/src/Distribution/Client/CmdOutdated.hs --- a/src/Distribution/Client/CmdOutdated.hs +++ b/src/Distribution/Client/CmdOutdated.hs @@ -30,7 +30,7 @@ , DistDirLayout(distProjectRootDirectory, distProjectFile) ) import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy - ( instantiateProjectConfigSkeleton ) + ( instantiateProjectConfigSkeletonWithCompiler ) import Distribution.Client.ProjectFlags ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags , removeIgnoreProjectOption ) @@ -306,7 +306,7 @@ {- TODO: Support dist dir override -} Nothing projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout - pure $ instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty pcs + pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs let ucnstrs = map fst . projectConfigConstraints . projectConfigShared $ projectConfig deps = userConstraintsToDependencies ucnstrs diff --git a/src/Distribution/Client/CmdRepl.hs b/src/Distribution/Client/CmdRepl.hs --- a/src/Distribution/Client/CmdRepl.hs +++ b/src/Distribution/Client/CmdRepl.hs @@ -75,7 +75,7 @@ import Distribution.Types.ComponentName ( componentNameString ) import Distribution.Types.CondTree - ( CondTree(..), traverseCondTreeC ) + ( CondTree(..) ) import Distribution.Types.Dependency ( Dependency(..), mainLibSet ) import Distribution.Types.Library @@ -187,7 +187,7 @@ -- replAction :: NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO () replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags - = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags $ \targetCtx ctx targetSelectors -> do + = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do when (buildSettingOnlyDeps (buildSettings ctx)) $ die' verbosity $ "The repl command does not support '--only-dependencies'. " ++ "You may wish to use 'build --only-dependencies' and then " @@ -338,7 +338,12 @@ | packageId pkg /= pkgId = SpecificSourcePackage pkg | SourcePackage{..} <- pkg = SpecificSourcePackage $ pkg { srcpkgDescription = - srcpkgDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) + -- New dependencies are added to the original ones found in the + -- `targetBuildDepends` field. + -- `traverseBuildInfos` is used in order to update _all_ the + -- occurrences of the field `targetBuildDepends`. It ensures that + -- fields depending on the latter are also consistently updated. + srcpkgDescription & (L.traverseBuildInfos . L.targetBuildDepends) %~ (deps ++) } addDeps spec = spec diff --git a/src/Distribution/Client/CmdRun.hs b/src/Distribution/Client/CmdRun.hs --- a/src/Distribution/Client/CmdRun.hs +++ b/src/Distribution/Client/CmdRun.hs @@ -27,7 +27,8 @@ ( renderTargetSelector, showTargetSelector, renderTargetProblem, renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter, renderListCommaAnd ) + targetSelectorFilter, renderListCommaAnd, + renderListPretty ) import Distribution.Client.TargetProblem ( TargetProblem (..) ) @@ -42,11 +43,11 @@ import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Types.ComponentName - ( showComponentName ) + ( componentNameRaw ) import Distribution.Verbosity ( normal, silent ) import Distribution.Simple.Utils - ( wrapText, die', info, notice ) + ( wrapText, die', info, notice, safeHead ) import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor ) @@ -64,6 +65,7 @@ import Distribution.Client.ScriptUtils ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) ) +import Data.List (group) import qualified Data.Set as Set import System.Directory ( doesFileExist ) @@ -120,7 +122,7 @@ -- runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () runAction flags@NixStyleFlags {..} targetAndArgs globalFlags - = withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags $ \targetCtx ctx targetSelectors -> do + = withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do (baseCtx, defaultVerbosity) <- case targetCtx of ProjectContext -> return (ctx, normal) GlobalContext -> return (ctx, normal) @@ -424,14 +426,13 @@ renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) = "The run command is for running a single executable at once. The target '" ++ showTargetSelector targetSelector ++ "' refers to " - ++ renderTargetSelector targetSelector ++ " which includes " - ++ renderListCommaAnd ( ("the "++) <$> - showComponentName <$> - availableTargetComponentName <$> - foldMap - (\kind -> filterTargetsKind kind targets) - [ExeKind, TestKind, BenchKind] ) - ++ "." + ++ renderTargetSelector targetSelector ++ " which includes \n" + ++ unlines ((\(label, xs) -> "- " ++ label ++ ": " ++ renderListPretty xs) + <$> (zip ["executables", "test-suites", "benchmarks"] + $ filter (not . null) . map removeDuplicates + $ map (componentNameRaw . availableTargetComponentName) + <$> (flip filterTargetsKind $ targets) <$> [ExeKind, TestKind, BenchKind] )) + where removeDuplicates = catMaybes . map safeHead . group . sort renderRunProblem (TargetProblemMultipleTargets selectorMap) = "The run command is for running a single executable at once. The targets " diff --git a/src/Distribution/Client/CmdSdist.hs b/src/Distribution/Client/CmdSdist.hs --- a/src/Distribution/Client/CmdSdist.hs +++ b/src/Distribution/Client/CmdSdist.hs @@ -137,7 +137,7 @@ ------------------------------------------------------------------------------- sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO () -sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do +sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject let localPkgs = localPackages baseCtx @@ -196,6 +196,7 @@ { configVerbosity = sdistVerbosity , configDistPref = sdistDistDir } + , projectFlags = pf } mempty diff --git a/src/Distribution/Client/CmdUpdate.hs b/src/Distribution/Client/CmdUpdate.hs --- a/src/Distribution/Client/CmdUpdate.hs +++ b/src/Distribution/Client/CmdUpdate.hs @@ -85,7 +85,7 @@ ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n" ++ " " ++ pname ++ " v2-update hackage.haskell.org\n" ++ " Download hackage.haskell.org at a specific index state.\n\n" - ++ " " ++ pname ++ " new update hackage.haskell.org head.hackage\n" + ++ " " ++ pname ++ " v2-update hackage.haskell.org head.hackage\n" ++ " Download hackage.haskell.org and head.hackage\n" ++ " head.hackage must be a known repo-id. E.g. from\n" ++ " your cabal.project(.local) file.\n" diff --git a/src/Distribution/Client/Compat/Process.hs b/src/Distribution/Client/Compat/Process.hs deleted file mode 100644 --- a/src/Distribution/Client/Compat/Process.hs +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Compat.Process --- Copyright : (c) 2013 Liu Hao, Brent Yorgey --- License : BSD-style (see the file LICENSE) --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Cross-platform utilities for invoking processes. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Compat.Process ( - readProcessWithExitCode -) where - -import Prelude (FilePath, IO, String, return, (||)) - -import Control.Exception (catch, throw) -import System.Exit (ExitCode (ExitFailure)) -import System.IO.Error (isDoesNotExistError, isPermissionError) -import qualified System.Process as P - --- | @readProcessWithExitCode@ creates an external process, reads its --- standard output and standard error strictly, waits until the --- process terminates, and then returns the @ExitCode@ of the --- process, the standard output, and the standard error. --- --- See the documentation of the version from @System.Process@ for --- more information. --- --- The version from @System.Process@ behaves inconsistently across --- platforms when an executable with the given name is not found: in --- some cases it returns an @ExitFailure@, in others it throws an --- exception. This variant catches \"does not exist\" and --- \"permission denied\" exceptions and turns them into --- @ExitFailure@s. --- --- TODO: this doesn't use 'Distrubution.Compat.Process'. --- -readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String) -readProcessWithExitCode cmd args input = - P.readProcessWithExitCode cmd args input - `catch` \e -> if isDoesNotExistError e || isPermissionError e - then return (ExitFailure 127, "", "") - else throw e diff --git a/src/Distribution/Client/Config.hs b/src/Distribution/Client/Config.hs --- a/src/Distribution/Client/Config.hs +++ b/src/Distribution/Client/Config.hs @@ -22,12 +22,14 @@ showConfigWithComments, parseConfig, - getCabalDir, defaultConfigFile, defaultCacheDir, + defaultScriptBuildsDir, + defaultStoreDir, defaultCompiler, defaultInstallPath, defaultLogsDir, + defaultReportsDir, defaultUserInstall, baseSavedConfig, @@ -46,6 +48,7 @@ postProcessRepo, ) where +import Distribution.Compat.Environment (lookupEnv) import Distribution.Client.Compat.Prelude import Prelude () @@ -90,7 +93,7 @@ , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs - , PathTemplate, toPathTemplate ) + , PathTemplate, toPathTemplate) import Distribution.Deprecated.ParseUtils ( FieldDescr(..), liftField, runP , ParseResult(..), PError(..), PWarning(..) @@ -130,7 +133,7 @@ import Text.PrettyPrint.HughesPJ ( text, Doc ) import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory, renameFile ) + ( createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(XdgCache, XdgConfig, XdgState), renameFile, getAppUserDataDirectory, doesDirectoryExist ) import Network.URI ( URI(..), URIAuth(..), parseURI ) import System.FilePath @@ -138,7 +141,7 @@ import System.IO.Error ( isDoesNotExistError ) import Distribution.Compat.Environment - ( getEnvironment, lookupEnv ) + ( getEnvironment ) import qualified Data.Map as M import qualified Data.ByteString as BS @@ -302,6 +305,7 @@ installFineGrainedConflicts = combine installFineGrainedConflicts, installMinimizeConflictSet = combine installMinimizeConflictSet, installIndependentGoals = combine installIndependentGoals, + installPreferOldest = combine installPreferOldest, installShadowPkgs = combine installShadowPkgs, installStrongFlags = combine installStrongFlags, installAllowBootLibInstalls = combine installAllowBootLibInstalls, @@ -487,6 +491,9 @@ haddockKeepTempFiles = combine haddockKeepTempFiles, haddockVerbosity = combine haddockVerbosity, haddockCabalFilePath = combine haddockCabalFilePath, + haddockIndex = combine haddockIndex, + haddockBaseUrl = combine haddockBaseUrl, + haddockLib = combine haddockLib, haddockArgs = lastNonEmpty haddockArgs } where @@ -535,7 +542,7 @@ -- baseSavedConfig :: IO SavedConfig baseSavedConfig = do - userPrefix <- getCabalDir + userPrefix <- defaultInstallPrefix cacheDir <- defaultCacheDir logsDir <- defaultLogsDir return mempty { @@ -583,40 +590,91 @@ } } -defaultCabalDir :: IO FilePath -defaultCabalDir = getAppUserDataDirectory "cabal" - -getCabalDir :: IO FilePath -getCabalDir = do +-- | If @CABAL\_DIR@ is set or @~/.cabal@ exists, return that +-- directory. Otherwise returns Nothing. If this function returns +-- Nothing, then it implies that we are not using a single directory +-- for everything, but instead use XDG paths. Fundamentally, this +-- function is used to implement transparent backwards compatibility +-- with pre-XDG versions of cabal-install. +maybeGetCabalDir :: IO (Maybe FilePath) +maybeGetCabalDir = do mDir <- lookupEnv "CABAL_DIR" case mDir of - Nothing -> defaultCabalDir - Just dir -> return dir + Just dir -> return $ Just dir + Nothing -> do + defaultDir <- getAppUserDataDirectory "cabal" + dotCabalExists <- doesDirectoryExist defaultDir + return $ if dotCabalExists + then Just defaultDir + else Nothing +-- | The default behaviour of cabal-install is to use the XDG +-- directory standard. However, if @CABAL_DIR@ is set, we instead use +-- that directory as a single store for everything cabal-related, like +-- the old @~/.cabal@ behaviour. Also, for backwards compatibility, +-- if @~/.cabal@ exists we treat that as equivalent to @CABAL_DIR@ +-- being set. This function abstracts that decision-making. +getDefaultDir :: XdgDirectory -> FilePath -> IO FilePath +getDefaultDir xdg subdir = do + mDir <- maybeGetCabalDir + case mDir of + Just dir -> return $ dir subdir + Nothing -> getXdgDirectory xdg $ "cabal" subdir + +-- | The default prefix used for installation. +defaultInstallPrefix :: IO FilePath +defaultInstallPrefix = do + mDir <- maybeGetCabalDir + case mDir of + Just dir -> + return dir + Nothing -> do + dir <- getHomeDirectory + return $ dir ".local" + defaultConfigFile :: IO FilePath -defaultConfigFile = do - dir <- getCabalDir - return $ dir "config" +defaultConfigFile = + getDefaultDir XdgConfig "config" defaultCacheDir :: IO FilePath -defaultCacheDir = do - dir <- getCabalDir - return $ dir "packages" +defaultCacheDir = + getDefaultDir XdgCache "packages" +defaultScriptBuildsDir :: IO FilePath +defaultScriptBuildsDir = + getDefaultDir XdgCache "script-builds" + +defaultStoreDir :: IO FilePath +defaultStoreDir = + getDefaultDir XdgState "store" + defaultLogsDir :: IO FilePath -defaultLogsDir = do - dir <- getCabalDir - return $ dir "logs" +defaultLogsDir = + getDefaultDir XdgCache "logs" +defaultReportsDir :: IO FilePath +defaultReportsDir = + getDefaultDir XdgCache "reports" + defaultExtraPath :: IO [FilePath] defaultExtraPath = do - dir <- getCabalDir - return [dir "bin"] + mDir <- maybeGetCabalDir + case mDir of + Just dir -> + return [dir "bin"] + Nothing -> do + dir <- getHomeDirectory + return [dir ".local" "bin"] defaultInstallPath :: IO FilePath defaultInstallPath = do - dir <- getCabalDir - return (dir "bin") + mDir <- maybeGetCabalDir + case mDir of + Just dir -> + return $ dir "bin" + Nothing -> do + dir <- getHomeDirectory + return $ dir ".local" "bin" defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -632,7 +690,7 @@ str = "hackage.haskell.org" name = RepoName str uri = URI "http:" (Just (URIAuth "" str "")) "/" "" "" - -- Note that lots of old ~/.cabal/config files will have the old url + -- Note that lots of old config files will have the old url -- http://hackage.haskell.org/packages/archive -- but new config files can use the new url (without the /packages/archive) -- and avoid having to do a http redirect @@ -1426,7 +1484,7 @@ unlines (map (showPWarning "Error parsing additional config lines") ws) -- | Get the differences (as a pseudo code diff) between the user's --- '~/.cabal/config' and the one that cabal would generate if it didn't exist. +-- config file and the one that cabal would generate if it didn't exist. userConfigDiff :: Verbosity -> GlobalFlags -> [String] -> IO [String] userConfigDiff verbosity globalFlags extraLines = do userConfig <- loadRawConfig normal (globalConfigFile globalFlags) @@ -1473,7 +1531,7 @@ in (topAndTail left, topAndTail (drop 1 right)) --- | Update the user's ~/.cabal/config' keeping the user's customizations. +-- | Update the user's config file keeping the user's customizations. userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO () userConfigUpdate verbosity globalFlags extraLines = do userConfig <- loadRawConfig normal (globalConfigFile globalFlags) diff --git a/src/Distribution/Client/Configure.hs b/src/Distribution/Client/Configure.hs --- a/src/Distribution/Client/Configure.hs +++ b/src/Distribution/Client/Configure.hs @@ -73,8 +73,8 @@ import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.Version - ( Version, mkVersion, anyVersion, thisVersion - , VersionRange, orLaterVersion ) + ( Version, anyVersion, thisVersion + , VersionRange ) import Distribution.Simple.Utils as Utils ( warn, notice, debug, die' , defaultPackageDesc ) @@ -84,21 +84,12 @@ import System.FilePath ( () ) -- | Choose the Cabal version such that the setup scripts compiled against this --- version will support the given command-line flags. +-- version will support the given command-line flags. Currently, it implements no +-- specific restrictions and allows any version, unless the second argument is +-- filled with a 'Version', in which case this version is picked. chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange -chooseCabalVersion configExFlags maybeVersion = - maybe defaultVersionRange thisVersion maybeVersion - where - -- Cabal < 1.19.2 doesn't support '--exact-configuration' which is needed - -- for '--allow-newer' to work. - allowNewer = isRelaxDeps - (maybe mempty unAllowNewer $ configAllowNewer configExFlags) - allowOlder = isRelaxDeps - (maybe mempty unAllowOlder $ configAllowOlder configExFlags) - - defaultVersionRange = if allowOlder || allowNewer - then orLaterVersion (mkVersion [1,19,2]) - else anyVersion +chooseCabalVersion _configExFlags maybeVersion = + maybe anyVersion thisVersion maybeVersion -- | Configure the package found in the local directory configure :: Verbosity diff --git a/src/Distribution/Client/Dependency.hs b/src/Distribution/Client/Dependency.hs --- a/src/Distribution/Client/Dependency.hs +++ b/src/Distribution/Client/Dependency.hs @@ -109,7 +109,7 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.DependencyResolver -import Distribution.Solver.Types.InstalledPreference +import Distribution.Solver.Types.InstalledPreference as Preference import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint @@ -400,6 +400,9 @@ , pkgname <- [ mkPackageName "base" , mkPackageName "ghc-bignum" , mkPackageName "ghc-prim" + , mkPackageName "ghc-boot" + , mkPackageName "ghc" + , mkPackageName "ghci" , mkPackageName "integer-gmp" , mkPackageName "integer-simple" , mkPackageName "template-haskell" @@ -767,13 +770,14 @@ [ (pkgname, pref) | PackageInstalledPreference pkgname pref <- prefs ] installPrefDefault = case defaultPref of - PreferAllLatest -> const PreferLatest - PreferAllInstalled -> const PreferInstalled + PreferAllLatest -> const Preference.PreferLatest + PreferAllOldest -> const Preference.PreferOldest + PreferAllInstalled -> const Preference.PreferInstalled PreferLatestForSelected -> \pkgname -> -- When you say cabal install foo, what you really mean is, prefer the -- latest version of foo, but the installed version of everything else - if pkgname `Set.member` selected then PreferLatest - else PreferInstalled + if pkgname `Set.member` selected then Preference.PreferLatest + else Preference.PreferInstalled stanzasPref :: PackageName -> [OptionalStanza] stanzasPref pkgname = @@ -1019,8 +1023,9 @@ (installPref pkg, versionPref pkg, packageVersion pkg) installPref :: UnresolvedSourcePackage -> Bool installPref = case preferInstalled of - PreferLatest -> const False - PreferInstalled -> not . null + Preference.PreferLatest -> const False + Preference.PreferOldest -> const False + Preference.PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex . packageId diff --git a/src/Distribution/Client/Dependency/Types.hs b/src/Distribution/Client/Dependency/Types.hs --- a/src/Distribution/Client/Dependency/Types.hs +++ b/src/Distribution/Client/Dependency/Types.hs @@ -49,6 +49,13 @@ -- PreferAllLatest + -- | Always prefer the oldest version irrespective of any existing + -- installed version or packages explicitly requested. + -- + -- * This is enabled by --prefer-oldest. + -- + | PreferAllOldest + -- | Always prefer the installed versions over ones that would need to be -- installed. Secondarily, prefer latest versions (eg the latest installed -- version or if there are none then the latest source version). diff --git a/src/Distribution/Client/DistDirLayout.hs b/src/Distribution/Client/DistDirLayout.hs --- a/src/Distribution/Client/DistDirLayout.hs +++ b/src/Distribution/Client/DistDirLayout.hs @@ -27,6 +27,8 @@ import System.FilePath +import Distribution.Client.Config + ( defaultStoreDir, defaultLogsDir) import Distribution.Package ( PackageId, PackageIdentifier, ComponentId, UnitId ) import Distribution.Compiler @@ -292,19 +294,16 @@ storeIncomingDirectory compid prettyShow unitid <.> "lock" -defaultCabalDirLayout :: FilePath -> CabalDirLayout -defaultCabalDirLayout cabalDir = - mkCabalDirLayout cabalDir Nothing Nothing +defaultCabalDirLayout :: IO CabalDirLayout +defaultCabalDirLayout = + mkCabalDirLayout Nothing Nothing -mkCabalDirLayout :: FilePath -- ^ Cabal directory - -> Maybe FilePath -- ^ Store directory. Must be absolute +mkCabalDirLayout :: Maybe FilePath -- ^ Store directory. Must be absolute -> Maybe FilePath -- ^ Log directory - -> CabalDirLayout -mkCabalDirLayout cabalDir mstoreDir mlogDir = - CabalDirLayout {..} - where - cabalStoreDirLayout :: StoreDirLayout - cabalStoreDirLayout = - defaultStoreDirLayout (fromMaybe (cabalDir "store") mstoreDir) - cabalLogsDirectory :: FilePath - cabalLogsDirectory = fromMaybe (cabalDir "logs") mlogDir + -> IO CabalDirLayout +mkCabalDirLayout mstoreDir mlogDir = do + cabalStoreDirLayout <- + defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir + cabalLogsDirectory <- + maybe defaultLogsDir pure mlogDir + pure $ CabalDirLayout {..} diff --git a/src/Distribution/Client/FetchUtils.hs b/src/Distribution/Client/FetchUtils.hs --- a/src/Distribution/Client/FetchUtils.hs +++ b/src/Distribution/Client/FetchUtils.hs @@ -11,7 +11,7 @@ -- -- Functions for fetching packages ----------------------------------------------------------------------------- -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} module Distribution.Client.FetchUtils ( -- * fetching packages @@ -22,6 +22,7 @@ -- ** specifically for repo packages checkRepoTarballFetched, fetchRepoTarball, + verifyFetchedTarball, -- ** fetching packages asynchronously asyncFetchPackages, @@ -43,7 +44,7 @@ import Distribution.Package ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils - ( notice, info, debug, die' ) + ( notice, info, debug, warn, die' ) import Distribution.Verbosity ( verboseUnmarkOutput ) import Distribution.Client.GlobalFlags @@ -56,7 +57,8 @@ import Control.Concurrent.Async import Control.Concurrent.MVar import System.Directory - ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) + ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory + , getFileSize ) import System.IO ( openTempFile, hClose ) import System.FilePath @@ -67,6 +69,8 @@ ( URI(uriPath) ) import qualified Hackage.Security.Client as Sec +import qualified Hackage.Security.Util.Path as Sec +import qualified Hackage.Security.Util.Checked as Sec -- ------------------------------------------------------------ -- * Actually fetch things @@ -118,6 +122,38 @@ then return (Just file) else return Nothing +verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool +verifyFetchedTarball verbosity repoCtxt repo pkgid = + let file = packageFile repo pkgid + handleError :: IO Bool -> IO Bool + handleError act = do + res <- Safe.try act + case res of + Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False + Right b -> pure b + in handleError $ do + exists <- doesFileExist file + if not exists + then return True -- if the file does not exist, it vacuously passes validation, since it will be downloaded as necessary with what we will then check is a valid hash. + else case repo of + -- a secure repo has hashes we can compare against to confirm this is the correct file. + RepoSecure{} -> + repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> + Sec.withIndex repoSecure $ \callbacks -> + let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False + -- the do block in parens is due to dealing with the checked exceptions mechanism. + in (do fileInfo <- Sec.indexLookupFileInfo callbacks pkgid + sz <- Sec.FileLength . fromInteger <$> getFileSize file + if sz /= Sec.fileInfoLength (Sec.trusted fileInfo) + then warnAndFail "file length mismatch" + else do + res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute) + if res + then pure True + else warnAndFail "file hash mismatch") + `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e)) + `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e)) + _ -> pure True -- | Fetch a package if we don't have it already. -- @@ -290,7 +326,7 @@ -- ------------------------------------------------------------ -- | Generate the full path to the locally cached copy of --- the tarball for a given @PackageIdentifer@. +-- the tarball for a given @PackageIdentifier@. -- packageFile :: Repo -> PackageId -> FilePath packageFile repo pkgid = packageDir repo pkgid @@ -298,7 +334,7 @@ <.> "tar.gz" -- | Generate the full path to the directory where the local cached copy of --- the tarball for a given @PackageIdentifer@ is stored. +-- the tarball for a given @PackageIdentifier@ is stored. -- packageDir :: Repo -> PackageId -> FilePath packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir diff --git a/src/Distribution/Client/GenBounds.hs b/src/Distribution/Client/GenBounds.hs --- a/src/Distribution/Client/GenBounds.hs +++ b/src/Distribution/Client/GenBounds.hs @@ -19,7 +19,7 @@ import Distribution.Client.Compat.Prelude import Distribution.Client.Utils - ( incVersion ) + ( hasElem, incVersion ) import Distribution.Client.Freeze ( getFreezePkgs ) import Distribution.Client.Setup @@ -40,7 +40,7 @@ import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Utils - ( tryFindPackageDesc ) + ( notice, tryFindPackageDesc ) import Distribution.System ( Platform ) import Distribution.Version @@ -106,33 +106,29 @@ case epd of Left _ -> putStrLn "finalizePD failed" Right (pd,_) -> do - let needBounds = filter (not . hasUpperBound . depVersion) $ + let needBounds = map depName $ filter (not . hasUpperBound . depVersion) $ enabledBuildDepends pd defaultComponentRequestedSpec - if (null needBounds) - then putStrLn - "Congratulations, all your dependencies have upper bounds!" - else go needBounds - where - go needBounds = do pkgs <- getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags - putStrLn boundsNeededMsg - - let isNeeded pkg = unPackageName (packageName pkg) - `elem` map depName needBounds + let isNeeded = hasElem needBounds . unPackageName . packageName let thePkgs = filter isNeeded pkgs let padTo = maximum $ map (length . unPackageName . packageName) pkgs - traverse_ (putStrLn . (++",") . showBounds padTo) thePkgs - depName :: Dependency -> String - depName (Dependency pn _ _) = unPackageName pn + if null thePkgs then notice verbosity + "Congratulations, all your dependencies have upper bounds!" + else do + notice verbosity boundsNeededMsg + traverse_ (notice verbosity . (++",") . showBounds padTo) thePkgs - depVersion :: Dependency -> VersionRange - depVersion (Dependency _ vr _) = vr +depName :: Dependency -> String +depName (Dependency pn _ _) = unPackageName pn + +depVersion :: Dependency -> VersionRange +depVersion (Dependency _ vr _) = vr -- | The message printed when some dependencies are found to be lacking proper -- PVP-mandated bounds. diff --git a/src/Distribution/Client/Get.hs b/src/Distribution/Client/Get.hs --- a/src/Distribution/Client/Get.hs +++ b/src/Distribution/Client/Get.hs @@ -31,7 +31,7 @@ import Distribution.Simple.Setup ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils - ( notice, die', info, writeFileAtomic ) + ( notice, die', info, warn, writeFileAtomic ) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName ) @@ -49,8 +49,11 @@ import Distribution.Client.IndexUtils ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos ) import Distribution.Solver.Types.SourcePackage +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) import qualified Data.Map as Map +import Control.Monad ( mapM_ ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) import System.FilePath @@ -94,16 +97,26 @@ unless (null prefix) $ createDirectoryIfMissing True prefix - if useSourceRepo - then clone pkgs - else unpack pkgs + if onlyPkgDescr + then do + when useSourceRepo $ + warn verbosity $ + "Ignoring --source-repository for --only-package-description" + mapM_ (unpackOnlyPkgDescr verbosity prefix) pkgs + else + if useSourceRepo + then clone pkgs + else unpack pkgs + where resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams resolverParams sourcePkgDb pkgSpecifiers = --TODO: add command-line constraint and preference args for unpack standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags) + prefix :: String prefix = fromFlagOrDefault "" (getDestDir getFlags) @@ -188,6 +201,23 @@ ++ " with the latest revision from the index." writeFileAtomic descFilePath pkgtxt + +-- | Write a @pkgId.cabal@ file with the package description to the destination +-- directory, unless one already exists. +unpackOnlyPkgDescr :: Verbosity -> FilePath -> UnresolvedSourcePackage -> IO () +unpackOnlyPkgDescr verbosity dstDir pkg = do + let pkgFile = dstDir prettyShow (packageId pkg) <.> "cabal" + existsFile <- doesFileExist pkgFile + when existsFile $ die' verbosity $ + "The file \"" ++ pkgFile ++ "\" already exists, not overwriting." + existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile) + when existsDir $ die' verbosity $ + "A directory \"" ++ pkgFile ++ "\" is in the way, not unpacking." + notice verbosity $ "Writing package description to " ++ pkgFile + case srcpkgDescrOverride pkg of + Just pkgTxt -> writeFileAtomic pkgFile pkgTxt + Nothing -> + writeGenericPackageDescription pkgFile (srcpkgDescription pkg) -- ------------------------------------------------------------ -- * Cloning packages from their declared source repositories diff --git a/src/Distribution/Client/Haddock.hs b/src/Distribution/Client/Haddock.hs --- a/src/Distribution/Client/Haddock.hs +++ b/src/Distribution/Client/Haddock.hs @@ -41,7 +41,7 @@ -> IO () regenerateHaddockIndex verbosity pkgs progdb index = do (paths, warns) <- haddockPackagePaths pkgs' Nothing - let paths' = [ (interface, html) | (interface, Just html, _) <- paths] + let paths' = [ (interface, html) | (interface, Just html, _, _) <- paths] for_ warns (debug verbosity) (confHaddock, _, _) <- diff --git a/src/Distribution/Client/HttpUtils.hs b/src/Distribution/Client/HttpUtils.hs --- a/src/Distribution/Client/HttpUtils.hs +++ b/src/Distribution/Client/HttpUtils.hs @@ -500,7 +500,7 @@ warningMsg = "the 'wget' transport currently doesn't support" ++ " range requests, which wastes network bandwidth." ++ " To fix this, set 'http-transport' to 'curl' or" - ++ " 'plain-http' in '~/.cabal/config'." + ++ " 'plain-http' in '~/.config/cabal/config'." ++ " Note that the 'plain-http' transport doesn't" ++ " support HTTPS.\n" diff --git a/src/Distribution/Client/Init/Format.hs b/src/Distribution/Client/Init/Format.hs --- a/src/Distribution/Client/Init/Format.hs +++ b/src/Distribution/Client/Init/Format.hs @@ -123,7 +123,7 @@ mkCommonStanza :: WriteOpts -> PrettyField FieldAnnotation mkCommonStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of NoCommonStanzas -> PrettyEmpty - _ -> PrettySection + _ -> PrettySection annNoComments "common" [text "warnings"] @@ -136,7 +136,7 @@ NoCommonStanzas -> PrettyEmpty _ -> field "import" (hsep . map text) ["warnings"] ["Import common warning flags."] - False + False opts , field "exposed-modules" formatExposedModules (toList expMods) @@ -182,9 +182,9 @@ NoCommonStanzas -> PrettyEmpty _ -> field "import" (hsep . map text) ["warnings"] ["Import common warning flags."] - False + False opts - + , field "main-is" unsafeFromHs exeMain [".hs or .lhs file containing the Main module."] True @@ -230,9 +230,9 @@ NoCommonStanzas -> PrettyEmpty _ -> field "import" (hsep . map text) ["warnings"] ["Import common warning flags."] - False + False opts - + , field "default-language" id lang ["Base language which the package is written in."] True diff --git a/src/Distribution/Client/Init/Interactive/Command.hs b/src/Distribution/Client/Init/Interactive/Command.hs --- a/src/Distribution/Client/Init/Interactive/Command.hs +++ b/src/Distribution/Client/Init/Interactive/Command.hs @@ -297,7 +297,7 @@ packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName packageNamePrompt srcDb flags = getPackageName flags $ do defName <- case packageDir flags of - Flag b -> return $ filePathToPkgName b + Flag b -> filePathToPkgName b NoFlag -> currentDirPkgName go $ DefaultPrompt defName @@ -416,7 +416,7 @@ let h2010 = "Haskell2010" h98 = "Haskell98" ghc2021 = "GHC2021 (requires at least GHC 9.2)" - + l <- promptList ("Choose a language for your " ++ pkgType) [h2010, h98, ghc2021] (DefaultPrompt h2010) @@ -427,13 +427,7 @@ | l == h2010 -> return Haskell2010 | l == h98 -> return Haskell98 | l == ghc2021 -> return GHC2021 - | all isAlphaNum l -> return $ UnknownLanguage l - | otherwise -> do - putStrLn - $ "\nThe language must be alphanumeric. " - ++ "Please enter a different language." - - languagePrompt flags pkgType + | otherwise -> return $ UnknownLanguage l noCommentsPrompt :: Interactive m => InitFlags -> m Bool noCommentsPrompt flags = getNoComments flags $ do diff --git a/src/Distribution/Client/Init/NonInteractive/Command.hs b/src/Distribution/Client/Init/NonInteractive/Command.hs --- a/src/Distribution/Client/Init/NonInteractive/Command.hs +++ b/src/Distribution/Client/Init/NonInteractive/Command.hs @@ -139,7 +139,7 @@ return $ ProjectSettings (mkOpts comments cabalSpec) pkgDesc (Just libTarget) (Just exeTarget) testTarget - + TestSuite -> do testTarget <- genTestTarget initFlags comp pkgIx cabalSpec @@ -358,7 +358,7 @@ otherModules' <- libOtherModulesHeuristics flags return $ filter (`notElem` otherModules') modulesNames - + else return [] diff --git a/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/src/Distribution/Client/Init/NonInteractive/Heuristics.hs --- a/src/Distribution/Client/Init/NonInteractive/Heuristics.hs +++ b/src/Distribution/Client/Init/NonInteractive/Heuristics.hs @@ -27,7 +27,6 @@ ) where import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many) -import Distribution.Utils.Generic (safeLast) import Distribution.Simple.Setup (fromFlagOrDefault) @@ -40,7 +39,7 @@ import Distribution.CabalSpecVersion import Language.Haskell.Extension import Distribution.Version -import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Types.PackageName (PackageName) import Distribution.Simple.Compiler import qualified Data.Set as Set import Distribution.FieldGrammar.Newtypes @@ -82,24 +81,7 @@ -- | Guess the package name based on the given root directory. guessPackageName :: Interactive m => FilePath -> m PackageName -guessPackageName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) - . canonicalizePathNoThrow - where - -- Treat each span of non-alphanumeric characters as a hyphen. Each - -- hyphenated component of a package name must contain at least one - -- alphabetic character. An arbitrary character ('x') will be prepended if - -- this is not the case for the first component, and subsequent components - -- will simply be run together. For example, "1+2_foo-3" will become - -- "x12-foo3". - repair = repair' ('x' :) id - repair' invalid valid x = case dropWhile (not . isAlphaNum) x of - "" -> repairComponent "" - x' -> let (c, r) = first repairComponent $ span isAlphaNum x' - in c ++ repairRest r - where - repairComponent c | all isDigit c = invalid c - | otherwise = valid c - repairRest = repair' id ('-' :) +guessPackageName = filePathToPkgName -- | Try to guess the license from an already existing @LICENSE@ file in -- the package directory, comparing the file contents with the ones @@ -125,7 +107,7 @@ guessPackageType flags = do if fromFlagOrDefault False (initializeTestSuite flags) then - return TestSuite + return TestSuite else do let lastDir dirs = L.last . splitDirectories $ dirs srcCandidates = [defaultSourceDir, "src", "source"] diff --git a/src/Distribution/Client/Init/Simple.hs b/src/Distribution/Client/Init/Simple.hs --- a/src/Distribution/Client/Init/Simple.hs +++ b/src/Distribution/Client/Init/Simple.hs @@ -16,7 +16,7 @@ import qualified Data.List.NonEmpty as NEL import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep, fixupDocFiles) import Distribution.Client.Init.Defaults -import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag(..)) +import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag (..)) import Distribution.Client.Init.FlagExtractors import qualified Data.Set as Set import Distribution.Types.Dependency @@ -170,6 +170,6 @@ return $ initFlags { dependencies = Flag $ based ++ as } - _ -> do + NoFlag -> do based <- dependenciesPrompt pkgIx initFlags return initFlags { dependencies = Flag based } diff --git a/src/Distribution/Client/Init/Types.hs b/src/Distribution/Client/Init/Types.hs --- a/src/Distribution/Client/Init/Types.hs +++ b/src/Distribution/Client/Init/Types.hs @@ -72,7 +72,7 @@ import qualified System.IO import qualified System.Directory as P -import qualified System.Process as P +import qualified System.Process as Process import qualified Distribution.Compat.Environment as P import System.FilePath import Distribution.FieldGrammar.Newtypes (SpecLicense) @@ -342,7 +342,7 @@ doesDirectoryExist = P.doesDirectoryExist doesFileExist = P.doesFileExist canonicalizePathNoThrow = P.canonicalizePathNoThrow - readProcessWithExitCode = P.readProcessWithExitCode + readProcessWithExitCode = Process.readProcessWithExitCode getEnvironment = P.getEnvironment getCurrentYear = P.getCurrentYear listFilesInside = P.listFilesInside diff --git a/src/Distribution/Client/Init/Utils.hs b/src/Distribution/Client/Init/Utils.hs --- a/src/Distribution/Client/Init/Utils.hs +++ b/src/Distribution/Client/Init/Utils.hs @@ -23,9 +23,9 @@ ) where -import qualified Prelude +import qualified Prelude () import Distribution.Client.Compat.Prelude hiding (putStrLn, empty, readFile, Parsec, many) -import Distribution.Utils.Generic (isInfixOf) +import Distribution.Utils.Generic (isInfixOf, safeLast) import Control.Monad (forM) @@ -38,7 +38,6 @@ import Distribution.ModuleName (ModuleName) import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed) import qualified Distribution.Package as P -import qualified Distribution.Types.PackageName as PN import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex) import Distribution.Simple.Setup (Flag(..)) import Distribution.Utils.String (trim) @@ -277,11 +276,28 @@ Flag x -> x < CabalSpecV2_0 NoFlag -> defaultCabalVersion < CabalSpecV2_0 -filePathToPkgName :: FilePath -> P.PackageName -filePathToPkgName = PN.mkPackageName . Prelude.last . splitDirectories +filePathToPkgName :: Interactive m => FilePath -> m P.PackageName +filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) + . canonicalizePathNoThrow + where + -- Treat each span of non-alphanumeric characters as a hyphen. Each + -- hyphenated component of a package name must contain at least one + -- alphabetic character. An arbitrary character ('x') will be prepended if + -- this is not the case for the first component, and subsequent components + -- will simply be run together. For example, "1+2_foo-3" will become + -- "x12-foo3". + repair = repair' ('x' :) id + repair' invalid valid x = case dropWhile (not . isAlphaNum) x of + "" -> repairComponent "" + x' -> let (c, r) = first repairComponent $ span isAlphaNum x' + in c ++ repairRest r + where + repairComponent c | all isDigit c = invalid c + | otherwise = valid c + repairRest = repair' id ('-' :) currentDirPkgName :: Interactive m => m P.PackageName -currentDirPkgName = filePathToPkgName <$> getCurrentDirectory +currentDirPkgName = filePathToPkgName =<< getCurrentDirectory mkPackageNameDep :: PackageName -> Dependency mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName) diff --git a/src/Distribution/Client/Install.hs b/src/Distribution/Client/Install.hs --- a/src/Distribution/Client/Install.hs +++ b/src/Distribution/Client/Install.hs @@ -71,7 +71,7 @@ , ConfigExFlags(..), InstallFlags(..) , filterTestFlags ) import Distribution.Client.Config - ( getCabalDir, defaultUserInstall ) + ( defaultReportsDir, defaultUserInstall ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types @@ -197,7 +197,7 @@ warn verbosity $ "--root-cmd is no longer supported, " ++ "see https://github.com/haskell/cabal/issues/3353" ++ " (if you didn't type --root-cmd, comment out root-cmd" - ++ " in your ~/.cabal/config file)" + ++ " in your ~/.config/cabal/config file)" let userOrSandbox = fromFlag (configUserInstall configFlags) unless userOrSandbox $ warn verbosity $ "the --global flag is deprecated -- " @@ -831,10 +831,10 @@ storeDetailedBuildReports :: Verbosity -> FilePath -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do dotCabal <- getCabalDir + [ do allReportsDir <- defaultReportsDir let logFileName = prettyShow (BuildReports.package report) <.> "log" logFile = logsDir logFileName - reportsDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) + reportsDir = allReportsDir unRepoName (remoteRepoName remoteRepo) reportFile = reportsDir logFileName handleMissingLogFile $ do diff --git a/src/Distribution/Client/Manpage.hs b/src/Distribution/Client/Manpage.hs --- a/src/Distribution/Client/Manpage.hs +++ b/src/Distribution/Client/Manpage.hs @@ -27,15 +27,14 @@ import Distribution.Client.Init.Utils (trim) import Distribution.Client.ManpageFlags import Distribution.Client.Setup (globalCommand) +import Distribution.Compat.Process (proc) import Distribution.Simple.Command -import Distribution.Simple.Flag (fromFlagOrDefault) +import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault) import Distribution.Simple.Utils - ( IOData(..), IODataMode(..), createProcessWithEnv, ignoreSigPipe, rawSystemStdInOut ) -import qualified Distribution.Verbosity as Verbosity + ( IOData(..), IODataMode(..), ignoreSigPipe, rawSystemStdInOut, rawSystemProcAction, + fromCreatePipe, die' ) import System.IO (hClose, hPutStr) import System.Environment (lookupEnv) -import System.FilePath (takeFileName) - import qualified System.Process as Process data FileInfo = FileInfo String String -- ^ path, description @@ -47,7 +46,7 @@ -- | A list of files that should be documented in the manual page. files :: [FileInfo] files = - [ (FileInfo "~/.cabal/config" "The defaults that can be overridden with command-line options.") + [ (FileInfo "~/.config/cabal/config" "The defaults that can be overridden with command-line options.") ] manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO () @@ -69,7 +68,7 @@ -- Feed contents into @nroff -man /dev/stdin@ (formatted, _errors, ec1) <- rawSystemStdInOut - Verbosity.normal + verbosity "nroff" [ "-man", "/dev/stdin" ] Nothing -- Inherit working directory @@ -79,26 +78,23 @@ unless (ec1 == ExitSuccess) $ exitWith ec1 - pager <- fromMaybe "less" <$> lookupEnv "PAGER" - -- 'less' is borked with color sequences otherwise - let pagerArgs = if takeFileName pager == "less" then ["-R"] else [] + pagerAndArgs <- fromMaybe "less -R" <$> lookupEnv "PAGER" + -- 'less' is borked with color sequences otherwise, hence -R + (pager, pagerArgs) <- case words pagerAndArgs of + [] -> die' verbosity "man: empty value of the PAGER environment variable" + (p:pa) -> pure (p, pa) -- Pipe output of @nroff@ into @less@ - (Just inLess, _, _, procLess) <- createProcessWithEnv - Verbosity.normal - pager - pagerArgs - Nothing -- Inherit working directory - Nothing -- Inherit environment - Process.CreatePipe -- in - Process.Inherit -- out - Process.Inherit -- err - - hPutStr inLess formatted - hClose inLess - exitWith =<< Process.waitForProcess procLess + (ec2, _) <- rawSystemProcAction verbosity + (proc pager pagerArgs) { Process.std_in = Process.CreatePipe } + $ \mIn _ _ -> do + let wIn = fromCreatePipe mIn + hPutStr wIn formatted + hClose wIn + exitWith ec2 where contents :: String contents = manpage pname commands + verbosity = fromFlag $ manpageVerbosity flags -- | Produces a manual page with @troff@ markup. manpage :: String -> [CommandSpec a] -> String diff --git a/src/Distribution/Client/PackageHash.hs b/src/Distribution/Client/PackageHash.hs --- a/src/Distribution/Client/PackageHash.hs +++ b/src/Distribution/Client/PackageHash.hs @@ -196,6 +196,7 @@ pkgHashDebugInfo :: DebugInfoLevel, pkgHashProgramArgs :: Map String [String], pkgHashExtraLibDirs :: [FilePath], + pkgHashExtraLibDirsStatic :: [FilePath], pkgHashExtraFrameworkDirs :: [FilePath], pkgHashExtraIncludeDirs :: [FilePath], pkgHashProgPrefix :: Maybe PathTemplate, @@ -215,7 +216,10 @@ pkgHashHaddockCss :: Maybe FilePath, pkgHashHaddockLinkedSource :: Bool, pkgHashHaddockQuickJump :: Bool, - pkgHashHaddockContents :: Maybe PathTemplate + pkgHashHaddockContents :: Maybe PathTemplate, + pkgHashHaddockIndex :: Maybe PathTemplate, + pkgHashHaddockBaseUrl :: Maybe String, + pkgHashHaddockLib :: Maybe String -- TODO: [required eventually] pkgHashToolsVersions ? -- TODO: [required eventually] pkgHashToolsExtraOptions ? @@ -290,6 +294,7 @@ , opt "stripped-exe" True prettyShow pkgHashStripExes , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs + , opt "extra-lib-dirs-static" [] unwords pkgHashExtraLibDirsStatic , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix @@ -309,6 +314,9 @@ , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents + , opt "haddock-index-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockIndex + , opt "haddock-base-url" Nothing (fromMaybe "") pkgHashHaddockBaseUrl + , opt "haddock-lib" Nothing (fromMaybe "") pkgHashHaddockLib ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs where diff --git a/src/Distribution/Client/ProjectConfig.hs b/src/Distribution/Client/ProjectConfig.hs --- a/src/Distribution/Client/ProjectConfig.hs +++ b/src/Distribution/Client/ProjectConfig.hs @@ -119,7 +119,7 @@ ( PathTemplate, fromPathTemplate , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.Utils - ( die', warn, notice, info, createDirectoryIfMissingVerbose, rawSystemIOWithEnv ) + ( die', warn, notice, info, createDirectoryIfMissingVerbose, maybeExit, rawSystemIOWithEnv ) import Distribution.Client.Utils ( determineNumJobs ) import Distribution.Utils.NubList @@ -254,6 +254,7 @@ solverSettingIndexState = flagToMaybe projectConfigIndexState solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals + solverSettingPreferOldest = fromFlag projectConfigPreferOldest --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs --solverSettingReinstall = fromFlag projectConfigReinstall --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls @@ -274,7 +275,8 @@ projectConfigStrongFlags = Flag (StrongFlags False), projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False), projectConfigOnlyConstrained = Flag OnlyConstrainedNone, - projectConfigIndependentGoals = Flag (IndependentGoals False) + projectConfigIndependentGoals = Flag (IndependentGoals False), + projectConfigPreferOldest = Flag (PreferOldest False) --projectConfigShadowPkgs = Flag False, --projectConfigReinstall = Flag False, --projectConfigAvoidReinstalls = Flag False, @@ -465,7 +467,7 @@ -> Flag Bool -- ^ whether to ignore local project (--ignore-project flag) -> Flag FilePath -- ^ @--cabal-config@ -> IO a -- ^ with project - -> (ProjectConfig -> IO a) -- ^ without projet + -> (ProjectConfig -> IO a) -- ^ without project -> IO a withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf @@ -620,7 +622,7 @@ writeFile file . showProjectConfig --- | Read the user's @~/.cabal/config@ file. +-- | Read the user's cabal-install config file. -- readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig readGlobalConfig verbosity configFileFlag = do @@ -1175,8 +1177,7 @@ -- Run post-checkout-command if it is specified for_ repoGroupWithPaths $ \(repo, _, repoPath) -> for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do - exitCode <- rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing - unless (exitCode == ExitSuccess) $ exitWith exitCode + maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing -- But for reading we go through each 'SourceRepo' including its subdir -- value and have to know which path each one ended up in. diff --git a/src/Distribution/Client/ProjectConfig/Legacy.hs b/src/Distribution/Client/ProjectConfig/Legacy.hs --- a/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -7,7 +7,8 @@ -- Project config skeletons ProjectConfigSkeleton, parseProjectSkeleton, - instantiateProjectConfigSkeleton, + instantiateProjectConfigSkeletonFetchingCompiler, + instantiateProjectConfigSkeletonWithCompiler, singletonProjectConfigSkeleton, projectSkeletonImports, @@ -44,7 +45,7 @@ ( ClientInstallFlags(..), defaultClientInstallFlags , clientInstallOptions ) -import Distribution.Compat.Lens (view) +import Distribution.Compat.Lens (view, toListOf) import Distribution.Solver.Types.ConstraintSource @@ -52,7 +53,7 @@ import Distribution.Package import Distribution.Types.SourceRepo (RepoType) import Distribution.Types.CondTree - ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC ) + ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC, traverseCondTreeV, ignoreConditions ) import Distribution.PackageDescription ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment ) import Distribution.PackageDescription.Configuration (simplifyWithSysParams) @@ -66,7 +67,7 @@ , TestFlags(..), testOptions', defaultTestFlags , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo) - , readPackageDb, showPackageDb + , readPackageDb, showPackageDb, installDirsOptions ) import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags) @@ -101,7 +102,7 @@ import Distribution.Client.ParseUtils import Distribution.Simple.Command ( CommandUI(commandOptions), ShowOrParseArgs(..) - , OptionField, option, reqArg' ) + , OptionField(..), option, reqArg' ) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint ) import Distribution.Parsec (ParsecParser, parsecToken) @@ -116,7 +117,7 @@ import Distribution.Fields.ConfVar (parseConditionConfVarFromClause) import Distribution.Client.HttpUtils -import System.FilePath ((), isPathSeparator, makeValid) +import System.FilePath ((), isPathSeparator, makeValid, isAbsolute, takeDirectory) import System.Directory (createDirectoryIfMissing) @@ -135,8 +136,16 @@ singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton singletonProjectConfigSkeleton x = CondNode x mempty mempty -instantiateProjectConfigSkeleton :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig -instantiateProjectConfigSkeleton os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel +instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig +instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel + | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel) + | otherwise = do + (os, arch, impl) <- fetch + pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel + + +instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig +instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel where go :: CondTree FlagName @@ -215,7 +224,8 @@ createDirectoryIfMissing True cacheDir _ <- downloadURI httpTransport verbosity uri fp BS.readFile fp - Nothing -> BS.readFile pci + Nothing -> BS.readFile $ + if isAbsolute pci then pci else takeDirectory source pci modifiesCompiler :: ProjectConfig -> Bool modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg @@ -346,9 +356,17 @@ splitConfig pc = (pc , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc - , packageConfigDocumentation = packageConfigDocumentation pc }) --- | Convert from the types currently used for the user-wide @~/.cabal/config@ + -- Some flags to haddock should be passed to dependencies + , packageConfigDocumentation = packageConfigDocumentation pc + , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc + , packageConfigHaddockHtml = packageConfigHaddockHtml pc + , packageConfigHaddockInternal = packageConfigHaddockInternal pc + , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc + , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc + }) + +-- | Convert from the types currently used for the user-wide Cabal config -- file into the 'ProjectConfig' type. -- -- Only a subset of the 'ProjectConfig' can be represented in the user-wide @@ -484,7 +502,7 @@ configHcPath = projectConfigHcPath, configHcPkg = projectConfigHcPkg, --configProgramPathExtra = projectConfigProgPathExtra DELETE ME - --configInstallDirs = projectConfigInstallDirs, + configInstallDirs = projectConfigInstallDirs, --configUserInstall = projectConfigUserInstall, configPackageDBs = projectConfigPackageDBs } = configFlags @@ -514,6 +532,7 @@ installMinimizeConflictSet = projectConfigMinimizeConflictSet, installPerComponent = projectConfigPerComponent, installIndependentGoals = projectConfigIndependentGoals, + installPreferOldest = projectConfigPreferOldest, --installShadowPkgs = projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, @@ -595,7 +614,10 @@ haddockLinkedSource = packageConfigHaddockLinkedSource, haddockQuickJump = packageConfigHaddockQuickJump, haddockHscolourCss = packageConfigHaddockHscolourCss, - haddockContents = packageConfigHaddockContents + haddockContents = packageConfigHaddockContents, + haddockIndex = packageConfigHaddockIndex, + haddockBaseUrl = packageConfigHaddockBaseUrl, + haddockLib = packageConfigHaddockLib } = haddockFlags TestFlags { @@ -724,7 +746,8 @@ configFlags = mempty { configVerbosity = projectConfigVerbosity, configDistPref = projectConfigDistDir, - configPackageDBs = projectConfigPackageDBs + configPackageDBs = projectConfigPackageDBs, + configInstallDirs = projectConfigInstallDirs } configExFlags = ConfigExFlags { @@ -756,6 +779,7 @@ installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installIndependentGoals = projectConfigIndependentGoals, + installPreferOldest = projectConfigPreferOldest, installShadowPkgs = mempty, --projectConfigShadowPkgs, installStrongFlags = projectConfigStrongFlags, installAllowBootLibInstalls = projectConfigAllowBootLibInstalls, @@ -821,7 +845,7 @@ configOptimization = mempty, configProgPrefix = mempty, configProgSuffix = mempty, - configInstallDirs = mempty, + configInstallDirs = projectConfigInstallDirs, configScratchDir = mempty, configDistPref = mempty, configCabalFilePath = mempty, @@ -956,6 +980,9 @@ haddockKeepTempFiles = mempty, haddockVerbosity = mempty, haddockCabalFilePath = mempty, + haddockIndex = packageConfigHaddockIndex, + haddockBaseUrl = packageConfigHaddockBaseUrl, + haddockLib = packageConfigHaddockLib, haddockArgs = mempty } @@ -1115,7 +1142,7 @@ (Disp.text . showPackageDb) (fmap readPackageDb parsecToken) configPackageDBs (\v conf -> conf { configPackageDBs = v }) ] - . filterFields ["verbose", "builddir" ] + . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions) . commandOptionsToFields $ configureOptions ParseArgs @@ -1165,7 +1192,7 @@ , "jobs", "keep-going", "offline", "per-component" -- solver flags: , "max-backjumps", "reorder-goals", "count-conflicts" - , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals" + , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals", "prefer-oldest" , "strong-flags" , "allow-boot-library-installs" , "reject-unconstrained-dependencies", "index-state" ] @@ -1275,7 +1302,8 @@ , "foreign-libraries" , "executables", "tests", "benchmarks", "all", "internal", "css" , "hyperlink-source", "quickjump", "hscolour-css" - , "contents-location", "keep-temp-files" + , "contents-location", "index-location", "keep-temp-files", "base-url" + , "lib" ] . commandOptionsToFields ) (haddockOptions ParseArgs) @@ -1310,7 +1338,6 @@ [] . commandOptionsToFields ) (benchmarkOptions' ParseArgs) - where overrideFieldCompiler = diff --git a/src/Distribution/Client/ProjectConfig/Types.hs b/src/Distribution/Client/ProjectConfig/Types.hs --- a/src/Distribution/Client/ProjectConfig/Types.hs +++ b/src/Distribution/Client/ProjectConfig/Types.hs @@ -61,7 +61,7 @@ import Distribution.Simple.Setup ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) ) import Distribution.Simple.InstallDirs - ( PathTemplate ) + ( PathTemplate, InstallDirs ) import Distribution.Utils.NubList ( NubList ) @@ -73,7 +73,7 @@ -- | This type corresponds directly to what can be written in the -- @cabal.project@ file. Other sources of configuration can also be injected --- into this type, such as the user-wide @~/.cabal/config@ file and the +-- into this type, such as the user-wide config file and the -- command line of @cabal configure@ or @cabal build@. -- -- Since it corresponds to the external project file it is an instance of @@ -169,12 +169,11 @@ projectConfigHcPkg :: Flag FilePath, projectConfigHaddockIndex :: Flag PathTemplate, - -- Things that only make sense for manual mode, not --local mode + -- Only makes sense for manual mode, not --local mode -- too much control! --projectConfigUserInstall :: Flag Bool, - --projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), - --TODO: [required eventually] decide what to do with InstallDirs - -- currently we don't allow it to be specified in the config file + + projectConfigInstallDirs :: InstallDirs (Flag PathTemplate), projectConfigPackageDBs :: [Maybe PackageDB], -- configuration used both by the solver and other phases @@ -203,6 +202,7 @@ projectConfigOnlyConstrained :: Flag OnlyConstrained, projectConfigPerComponent :: Flag Bool, projectConfigIndependentGoals :: Flag IndependentGoals, + projectConfigPreferOldest :: Flag PreferOldest, projectConfigProgPathExtra :: NubList FilePath @@ -287,6 +287,9 @@ packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this + packageConfigHaddockIndex :: Flag PathTemplate, --TODO: [required eventually] use this + packageConfigHaddockBaseUrl :: Flag String, --TODO: [required eventually] use this + packageConfigHaddockLib :: Flag String, --TODO: [required eventually] use this packageConfigHaddockForHackage :: Flag HaddockTarget, -- Test options packageConfigTestHumanLog :: Flag PathTemplate, @@ -410,7 +413,8 @@ solverSettingOnlyConstrained :: OnlyConstrained, solverSettingIndexState :: Maybe TotalIndexState, solverSettingActiveRepos :: Maybe ActiveRepos, - solverSettingIndependentGoals :: IndependentGoals + solverSettingIndependentGoals :: IndependentGoals, + solverSettingPreferOldest :: PreferOldest -- Things that only make sense for manual mode, not --local mode -- too much control! --solverSettingShadowPkgs :: Bool, diff --git a/src/Distribution/Client/ProjectOrchestration.hs b/src/Distribution/Client/ProjectOrchestration.hs --- a/src/Distribution/Client/ProjectOrchestration.hs +++ b/src/Distribution/Client/ProjectOrchestration.hs @@ -138,7 +138,6 @@ import qualified Distribution.Client.BuildReports.Storage as BuildReports ( storeLocal ) -import Distribution.Client.Config (getCabalDir) import Distribution.Client.HttpUtils import Distribution.Client.Setup hiding (packageName) import Distribution.Compiler @@ -162,7 +161,7 @@ import qualified Distribution.Simple.Setup as Setup import Distribution.Simple.Command (commandShowOptions) import Distribution.Simple.Configure (computeEffectiveProfiling) - +import Distribution.Simple.PackageIndex (InstalledPackageIndex) import Distribution.Simple.Utils ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose, ordNub ) import Distribution.Verbosity @@ -187,7 +186,7 @@ -- | Tracks what command is being executed, because we need to hide this somewhere -- for cases that need special handling (usually for error reporting). -data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand +data CurrentCommand = InstallCommand | HaddockCommand | BuildCommand | ReplCommand | OtherCommand deriving (Show, Eq) -- | This holds the context of a project prior to solving: the content of the @@ -199,7 +198,8 @@ projectConfig :: ProjectConfig, localPackages :: [PackageSpecifier UnresolvedSourcePackage], buildSettings :: BuildTimeSettings, - currentCommand :: CurrentCommand + currentCommand :: CurrentCommand, + installedPackages :: Maybe InstalledPackageIndex } establishProjectBaseContext @@ -222,8 +222,6 @@ -> CurrentCommand -> IO ProjectBaseContext establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do - cabalDir <- getCabalDir - let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory httpTransport <- configureTransport verbosity @@ -247,9 +245,9 @@ mlogsDir = Setup.flagToMaybe projectConfigLogsDir mstoreDir <- sequenceA $ makeAbsolute <$> Setup.flagToMaybe projectConfigStoreDir - let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir - buildSettings = resolveBuildTimeSettings + let buildSettings = resolveBuildTimeSettings verbosity cabalDirLayout projectConfig @@ -263,11 +261,13 @@ projectConfig, localPackages, buildSettings, - currentCommand + currentCommand, + installedPackages } where mdistDirectory = Setup.flagToMaybe projectConfigDistDir ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig + installedPackages = Nothing -- | This holds the context between the pre-build, build and post-build phases. @@ -312,7 +312,8 @@ distDirLayout, cabalDirLayout, projectConfig, - localPackages + localPackages, + installedPackages } action = do -- Take the project configuration and make a plan for how to build @@ -324,6 +325,7 @@ distDirLayout cabalDirLayout projectConfig localPackages + installedPackages action elaboratedPlan elaboratedShared runProjectPreBuildPhase @@ -337,7 +339,8 @@ distDirLayout, cabalDirLayout, projectConfig, - localPackages + localPackages, + installedPackages } selectPlanSubset = do -- Take the project configuration and make a plan for how to build @@ -349,6 +352,7 @@ distDirLayout cabalDirLayout projectConfig localPackages + installedPackages -- The plan for what to do is represented by an 'ElaboratedInstallPlan' @@ -862,26 +866,26 @@ ProjectBaseContext { buildSettings = BuildTimeSettings{buildSettingDryRun}, projectConfig = ProjectConfig { + projectConfigAllPackages = + PackageConfig {packageConfigOptimization = globalOptimization}, projectConfigLocalPackages = - PackageConfig {packageConfigOptimization} - } + PackageConfig {packageConfigOptimization = localOptimization} + }, + currentCommand } ProjectBuildContext { elaboratedPlanToExecute = elaboratedPlan, elaboratedShared, pkgsBuildStatus } - - | null pkgs - = notice verbosity "Up to date" - - | otherwise - = noticeNoWrap verbosity $ unlines $ + | null pkgs && currentCommand == BuildCommand + = notice verbosity "Up to date" + | not (null pkgs) = noticeNoWrap verbosity $ unlines $ (showBuildProfile ++ "In order, the following " ++ wouldWill ++ " be built" ++ ifNormal " (use -v for more details)" ++ ":") : map showPkgAndReason pkgs - + | otherwise = return () where pkgs = InstallPlan.executionOrder elaboratedPlan @@ -997,7 +1001,7 @@ showBuildProfile :: String showBuildProfile = "Build profile: " ++ unwords [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared, - "-O" ++ (case packageConfigOptimization of + "-O" ++ (case globalOptimization <> localOptimization of -- if local is not set, read global Setup.Flag NoOptimisation -> "0" Setup.Flag NormalOptimisation -> "1" Setup.Flag MaximumOptimisation -> "2" @@ -1153,7 +1157,7 @@ , [pkg] <- rootpkgs , installedUnitId pkg == pkgid , isFailureSelfExplanatory (buildFailureReason failure) - , currentCommand /= InstallCommand + , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] = True | otherwise = False @@ -1319,8 +1323,6 @@ -> CurrentCommand -> IO ProjectBaseContext establishDummyProjectBaseContext verbosity projectConfig distDirLayout localPackages currentCommand = do - cabalDir <- getCabalDir - let ProjectConfigBuildOnly { projectConfigLogsDir } = projectConfigBuildOnly projectConfig @@ -1331,12 +1333,14 @@ mlogsDir = flagToMaybe projectConfigLogsDir mstoreDir = flagToMaybe projectConfigStoreDir - cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir - buildSettings :: BuildTimeSettings + cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir + + let buildSettings :: BuildTimeSettings buildSettings = resolveBuildTimeSettings verbosity cabalDirLayout projectConfig + installedPackages = Nothing return ProjectBaseContext { distDirLayout, @@ -1344,7 +1348,8 @@ projectConfig, localPackages, buildSettings, - currentCommand + currentCommand, + installedPackages } establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout diff --git a/src/Distribution/Client/ProjectPlanning.hs b/src/Distribution/Client/ProjectPlanning.hs --- a/src/Distribution/Client/ProjectPlanning.hs +++ b/src/Distribution/Client/ProjectPlanning.hs @@ -170,7 +170,9 @@ import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Monad.State as State +import Control.Monad (sequence, forM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.State as State (State, execState, runState, state) import Control.Exception (assert) import Data.List (groupBy, deleteBy) import qualified Data.List.NonEmpty as NE @@ -330,11 +332,14 @@ fileMonitorProjectConfigKey -- todo check deps too? $ do liftIO $ info verbosity "Project settings changed, reconfiguring..." - liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory projectConfigSkeleton <- phaseReadProjectConfig - -- have to create the cache directory before configuring the compiler - (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) - let projectConfig = instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty projectConfigSkeleton + let fetchCompiler = do + -- have to create the cache directory before configuring the compiler + liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory + (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig) + pure (os, arch, compilerInfo compiler) + + projectConfig <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig) return (projectConfig, localPackages) @@ -441,8 +446,8 @@ progdb = userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) . modifyProgramSearchPath - (++ [ ProgramSearchPathDir dir - | dir <- fromNubList packageConfigProgramPathExtra ]) + ([ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ] ++) $ defaultProgramDb @@ -463,6 +468,7 @@ -> DistDirLayout -> CabalDirLayout -> ProjectConfig -> [PackageSpecifier UnresolvedSourcePackage] + -> Maybe InstalledPackageIndex -> IO ( ElaboratedInstallPlan -- with store packages , ElaboratedInstallPlan -- with source packages , ElaboratedSharedConfig @@ -477,7 +483,7 @@ } CabalDirLayout { cabalStoreDirLayout - } = \projectConfig localPackages -> + } = \projectConfig localPackages mbInstalledPackages -> runRebuild distProjectRootDirectory $ do progsearchpath <- liftIO $ getSystemSearchPath let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty } @@ -500,6 +506,7 @@ <- phaseRunSolver projectConfig compilerEtc localPackages + (fromMaybe mempty mbInstalledPackages) (elaboratedPlan, elaboratedShared) <- phaseElaboratePlan projectConfig compilerEtc pkgConfigDB @@ -573,13 +580,15 @@ :: ProjectConfig -> (Compiler, Platform, ProgramDb) -> [PackageSpecifier UnresolvedSourcePackage] + -> InstalledPackageIndex -> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos) phaseRunSolver projectConfig@ProjectConfig { projectConfigShared, projectConfigBuildOnly } (compiler, platform, progdb) - localPackages = + localPackages + installedPackages = rerunIfChanged verbosity fileMonitorSolverPlan (solverSettings, localPackages, localPackagesEnabledStanzas, @@ -606,7 +615,7 @@ notice verbosity "Resolving dependencies..." planOrError <- foldProgress logMsg (pure . Left) (pure . Right) $ planPackages verbosity compiler platform solver solverSettings - installedPkgIndex sourcePkgDb pkgConfigDB + (installedPackages <> installedPkgIndex) sourcePkgDb pkgConfigDB localPackages localPackagesEnabledStanzas case planOrError of Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages @@ -676,6 +685,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler + let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared) (elaboratedPlan, elaboratedShared) <- liftIO . runLogProgress verbosity $ elaborateInstallPlan @@ -686,7 +696,7 @@ solverPlan localPackages sourcePackageHashes - defaultInstallDirs + installDirs projectConfigShared projectConfigAllPackages projectConfigLocalPackages @@ -694,7 +704,7 @@ let instantiatedPlan = instantiateInstallPlan cabalStoreDirLayout - defaultInstallDirs + installDirs elaboratedShared elaboratedPlan liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) @@ -913,9 +923,9 @@ -- Tarballs from repositories, either where the repository provides -- hashes as part of the repo metadata, or where we will have to -- download and hash the tarball. - repoTarballPkgsWithMetadata :: [(PackageId, Repo)] + repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)] repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)] - (repoTarballPkgsWithMetadata, + (repoTarballPkgsWithMetadataUnvalidated, repoTarballPkgsWithoutMetadata) = partitionEithers [ case repo of @@ -923,10 +933,16 @@ _ -> Right (pkgid, repo) | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ] + (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $ + liftIO $ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $ + \x@(pkg, repo) -> verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of + True -> return $ Left x + False -> return $ Right x + -- For tarballs from repos that do not have hashes available we now have -- to check if the packages were downloaded already. -- - (repoTarballPkgsToDownload, + (repoTarballPkgsToDownloadWithNoMeta, repoTarballPkgsDownloaded) <- fmap partitionEithers $ liftIO $ sequence @@ -936,6 +952,7 @@ Just tarball -> return (Right (pkgid, tarball)) | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ] + let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta (hashesFromRepoMetadata, repoTarballPkgsNewlyDownloaded) <- -- Avoid having to initialise the repository (ie 'withRepoCtx') if we @@ -1030,7 +1047,6 @@ planPackages verbosity comp platform solver SolverSettings{..} installedPkgIndex sourcePkgDb pkgConfigDB localPackages pkgStanzasEnable = - resolveDependencies platform (compilerInfo comp) pkgConfigDB solver @@ -1076,7 +1092,10 @@ -- installed for global packages, or prefer latest even for -- global packages. Perhaps should be configurable but with a -- different name than "upgrade-dependencies". - . setPreferenceDefault PreferLatestForSelected + . setPreferenceDefault + (if Cabal.asBool solverSettingPreferOldest + then PreferAllOldest + else PreferLatestForSelected) {-(if solverSettingUpgradeDeps then PreferAllLatest else PreferLatestForSelected)-} @@ -1181,6 +1200,7 @@ -- respective major Cabal version bundled with the respective GHC -- release). -- + -- etc. -- GHC 9.2 needs Cabal >= 3.6 -- GHC 9.0 needs Cabal >= 3.4 -- GHC 8.10 needs Cabal >= 3.2 @@ -1197,6 +1217,7 @@ -- TODO: long-term, this compatibility matrix should be -- stored as a field inside 'Distribution.Compiler.Compiler' setupMinCabalVersionConstraint + | isGHC, compVer >= mkVersion [9,6] = mkVersion [3,10] | isGHC, compVer >= mkVersion [9,4] = mkVersion [3,8] | isGHC, compVer >= mkVersion [9,2] = mkVersion [3,6] | isGHC, compVer >= mkVersion [9,0] = mkVersion [3,4] @@ -1955,6 +1976,9 @@ elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents + elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex + elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl + elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog @@ -3432,7 +3456,6 @@ sysconfdir = prefix "etc" - computeInstallDirs :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig @@ -3741,9 +3764,13 @@ -> Verbosity -> FilePath -> Cabal.HaddockFlags -setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = +setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) (ElaboratedSharedConfig{..}) verbosity builddir = Cabal.HaddockFlags { - haddockProgramPaths = mempty, --unused, set at configure time + haddockProgramPaths = + case lookupProgram haddockProgram pkgConfigCompilerProgs of + Nothing -> mempty + Just prg -> [( programName haddockProgram + , locationPath (programLocation prg) )], haddockProgramArgs = mempty, --unused, set at configure time haddockHoogle = toFlag elabHaddockHoogle, haddockHtml = toFlag elabHaddockHtml, @@ -3763,6 +3790,9 @@ haddockKeepTempFiles = mempty, --TODO: from build settings haddockVerbosity = toFlag verbosity, haddockCabalFilePath = mempty, + haddockIndex = maybe mempty toFlag elabHaddockIndex, + haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl, + haddockLib = maybe mempty toFlag elabHaddockLib, haddockArgs = mempty } @@ -3897,6 +3927,7 @@ pkgHashDebugInfo = elabDebugInfo, pkgHashProgramArgs = elabProgramArgs, pkgHashExtraLibDirs = elabExtraLibDirs, + pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic, pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, pkgHashExtraIncludeDirs = elabExtraIncludeDirs, pkgHashProgPrefix = elabProgPrefix, @@ -3915,7 +3946,10 @@ pkgHashHaddockCss = elabHaddockCss, pkgHashHaddockLinkedSource = elabHaddockLinkedSource, pkgHashHaddockQuickJump = elabHaddockQuickJump, - pkgHashHaddockContents = elabHaddockContents + pkgHashHaddockContents = elabHaddockContents, + pkgHashHaddockIndex = elabHaddockIndex, + pkgHashHaddockBaseUrl = elabHaddockBaseUrl, + pkgHashHaddockLib = elabHaddockLib } where ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg diff --git a/src/Distribution/Client/ProjectPlanning/Types.hs b/src/Distribution/Client/ProjectPlanning/Types.hs --- a/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/src/Distribution/Client/ProjectPlanning/Types.hs @@ -292,6 +292,9 @@ elabHaddockQuickJump :: Bool, elabHaddockHscolourCss :: Maybe FilePath, elabHaddockContents :: Maybe PathTemplate, + elabHaddockIndex :: Maybe PathTemplate, + elabHaddockBaseUrl :: Maybe String, + elabHaddockLib :: Maybe String, elabTestMachineLog :: Maybe PathTemplate, elabTestHumanLog :: Maybe PathTemplate, diff --git a/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/src/Distribution/Client/Sandbox/PackageEnvironment.hs --- a/src/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -25,7 +25,7 @@ import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.Config ( SavedConfig(..) +import Distribution.Client.Config ( SavedConfig(..) , configFieldDescriptions , haddockFlagsFields , installDirsFields, withProgramsFields @@ -45,7 +45,7 @@ , commaListFieldParsec, commaNewLineListFieldParsec , liftField, lineNo, locatedErrorMsg , readFields - , showPWarning + , showPWarning , syntaxError, warning ) import System.Directory ( doesFileExist ) import System.FilePath ( () ) @@ -81,7 +81,7 @@ -- | Type of the current package environment. data PackageEnvironmentType = UserPackageEnvironment -- ^ './cabal.config' - | AmbientPackageEnvironment -- ^ '~/.cabal/config' + | AmbientPackageEnvironment -- ^ '~/.config/cabal/config' -- | Is there a 'cabal.config' in this directory? classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType @@ -271,7 +271,7 @@ showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv -- | Pretty-print the package environment with default values for empty fields --- commented out (just like the default ~/.cabal/config). +-- commented out (just like the default Cabal config file). showPackageEnvironmentWithComments :: (Maybe PackageEnvironment) -> PackageEnvironment -> String diff --git a/src/Distribution/Client/ScriptUtils.hs b/src/Distribution/Client/ScriptUtils.hs --- a/src/Distribution/Client/ScriptUtils.hs +++ b/src/Distribution/Client/ScriptUtils.hs @@ -6,7 +6,7 @@ -- | Utilities to help commands with scripts -- module Distribution.Client.ScriptUtils ( - getScriptCacheDirectoryRoot, getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, + getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory, withContextAndSelectors, AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, updateContextAndWriteProjectFile', fakeProjectSourcePackage, lSrcpkgDescription @@ -22,7 +22,7 @@ ( CabalSpecVersion (..), cabalSpecLatest) import Distribution.Client.ProjectOrchestration import Distribution.Client.Config - ( getCabalDir ) + ( defaultScriptBuildsDir ) import Distribution.Client.DistDirLayout ( DistDirLayout(..) ) import Distribution.Client.HashValue @@ -37,7 +37,7 @@ , projectConfigHttpTransport ) import Distribution.Client.ProjectConfig.Legacy ( ProjectConfigSkeleton - , parseProjectSkeleton, instantiateProjectConfigSkeleton ) + , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler ) import Distribution.Client.ProjectFlags ( flagIgnoreProject ) import Distribution.Client.RebuildMonad @@ -120,14 +120,6 @@ -- repl to deal with the fact that the repl is relative to the working directory and not -- the project root. --- | Get the directory where script builds are cached. --- --- @CABAL_DIR\/script-builds\/@ -getScriptCacheDirectoryRoot :: IO FilePath -getScriptCacheDirectoryRoot = do - cabalDir <- getCabalDir - return $ cabalDir "script-builds" - -- | Get the hash of a script's absolute path) -- -- Two hashes will be the same as long as the absolute paths @@ -138,14 +130,14 @@ -- | Get the directory for caching a script build. -- -- The only identity of a script is it's absolute path, so append the --- hashed path to @CABAL_DIR\/script-builds\/@ to get the cache directory. +-- hashed path to the @script-builds@ dir to get the cache directory. getScriptCacheDirectory :: FilePath -> IO FilePath -getScriptCacheDirectory script = () <$> getScriptCacheDirectoryRoot <*> getScriptHash script +getScriptCacheDirectory script = () <$> defaultScriptBuildsDir <*> getScriptHash script -- | Get the directory for caching a script build and ensure it exists. -- -- The only identity of a script is it's absolute path, so append the --- hashed path to @CABAL_DIR\/script-builds\/@ to get the cache directory. +-- hashed path to the @script-builds@ dir to get the cache directory. ensureScriptCacheDirectory :: Verbosity -> FilePath -> IO FilePath ensureScriptCacheDirectory verbosity script = do cacheDir <- getScriptCacheDirectory script @@ -179,10 +171,11 @@ -> NixStyleFlags a -- ^ Command line flags -> [String] -- ^ Target strings or a script and args. -> GlobalFlags -- ^ Global flags. + -> CurrentCommand -- ^ Current Command (usually for error reporting). -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) -- ^ The body of your command action. -> IO b -withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags act +withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act = withTemporaryTempDirectory $ \mkTmpDir -> do (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir) @@ -217,11 +210,11 @@ defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing] with = do - ctx <- establishProjectBaseContext verbosity cliConfig OtherCommand + ctx <- establishProjectBaseContext verbosity cliConfig cmd return (ProjectContext, ctx) without mkDir globalConfig = do distDirLayout <- establishDummyDistDirLayout verbosity (globalConfig <> cliConfig) =<< mkDir - ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] OtherCommand + ctx <- establishDummyProjectBaseContext verbosity (globalConfig <> cliConfig) distDirLayout [] cmd return (GlobalContext, ctx) scriptOrError script err = do exists <- doesFileExist script @@ -243,9 +236,11 @@ projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents - (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + let fetchCompiler = do + (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx) + pure (os, arch, compilerInfo compiler) - let projectCfg = instantiateProjectConfigSkeleton os arch (compilerInfo compiler) mempty projectCfgSkeleton :: ProjectConfig + projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just ctx' = ctx & lProjectConfig %~ (<> projectCfg) diff --git a/src/Distribution/Client/Setup.hs b/src/Distribution/Client/Setup.hs --- a/src/Distribution/Client/Setup.hs +++ b/src/Distribution/Client/Setup.hs @@ -112,7 +112,7 @@ import Distribution.Types.UnqualComponentName ( unqualComponentNameToPackageName ) import Distribution.PackageDescription - ( BuildType(..), RepoKind(..), LibraryName(..) ) + ( BuildType(..), RepoKind(..), LibraryName(..), Dependency ) import Distribution.System ( Platform ) import Distribution.ReadE ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString ) @@ -127,6 +127,8 @@ ) import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions) import Distribution.FieldGrammar.Newtypes (SpecVersion (..)) +import Distribution.Parsec + ( parsecCommaList ) import Data.List ( deleteFirstsBy ) @@ -238,41 +240,49 @@ "Commands:\n" ++ unlines ( [ startGroup "global" - , addCmd "update" - , addCmd "install" - , par + , addCmd "user-config" , addCmd "help" - , addCmd "info" + , par + , startGroup "package database" + , addCmd "update" , addCmd "list" - , addCmd "fetch" - , addCmd "user-config" + , addCmd "info" , par - , startGroup "package" - , addCmd "get" - , addCmd "unpack" + , startGroup "initialization and download" , addCmd "init" + , addCmd "fetch" + , addCmd "get" , par + , startGroup "project configuration" , addCmd "configure" + , addCmd "freeze" + , addCmd "gen-bounds" + , addCmd "outdated" + , par + , startGroup "project building and installing" , addCmd "build" + , addCmd "install" + , addCmd "haddock" + , addCmd "haddock-project" , addCmd "clean" , par - , addCmd "run" + , startGroup "running and testing" + , addCmd "list-bin" , addCmd "repl" - , addCmd "test" + , addCmd "run" , addCmd "bench" + , addCmd "test" + , addCmd "exec" , par + , startGroup "sanity checks and shipping" , addCmd "check" , addCmd "sdist" , addCmd "upload" , addCmd "report" , par - , addCmd "freeze" - , addCmd "gen-bounds" - , addCmd "outdated" - , addCmd "haddock" + , startGroup "deprecated" + , addCmd "unpack" , addCmd "hscolour" - , addCmd "exec" - , addCmd "list-bin" , par , startGroup "new-style projects (forwards-compatible aliases)" , addCmd "v2-build" @@ -298,12 +308,8 @@ , addCmd "v1-bench" , addCmd "v1-freeze" , addCmd "v1-haddock" - , addCmd "v1-exec" - , addCmd "v1-update" , addCmd "v1-install" , addCmd "v1-clean" - , addCmd "v1-sdist" - , addCmd "v1-doctest" , addCmd "v1-copy" , addCmd "v1-register" , addCmd "v1-reconfigure" @@ -360,6 +366,11 @@ ,multiOption "nix" globalNix (\v flags -> flags { globalNix = v }) [ + optArg' "(True or False)" (maybeToFlag . (readMaybe =<<)) (\case + Flag True -> [Just "enable"] + Flag False -> [Just "disable"] + NoFlag -> [Just "disable"]) "" ["nix"] + "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)", noArg (Flag True) [] ["enable-nix"] "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists", noArg (Flag False) [] ["disable-nix"] @@ -409,7 +420,6 @@ "Set a location for a cabal.config file for projects without their own cabal.config freeze file." globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v}) (reqArgFlag "FILE") - ] -- ------------------------------------------------------------ @@ -497,7 +507,7 @@ flags_2_5_0 = flags_3_7_0 { -- Cabal < 2.5 does not understand --dependency=pkg:component=cid -- (public sublibraries), so we convert it to the legacy - -- --dependency=pkg_or_internal_compoent=cid + -- --dependency=pkg_or_internal_component=cid configDependencies = let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) = Just $ GivenComponent @@ -943,6 +953,7 @@ fetchFineGrainedConflicts :: Flag FineGrainedConflicts, fetchMinimizeConflictSet :: Flag MinimizeConflictSet, fetchIndependentGoals :: Flag IndependentGoals, + fetchPreferOldest :: Flag PreferOldest, fetchShadowPkgs :: Flag ShadowPkgs, fetchStrongFlags :: Flag StrongFlags, fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls, @@ -964,6 +975,7 @@ fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), fetchIndependentGoals = Flag (IndependentGoals False), + fetchPreferOldest = Flag (PreferOldest False), fetchShadowPkgs = Flag (ShadowPkgs False), fetchStrongFlags = Flag (StrongFlags False), fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False), @@ -1027,6 +1039,7 @@ fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) + fetchPreferOldest (\v flags -> flags { fetchPreferOldest = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v }) fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v }) fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v }) @@ -1049,6 +1062,7 @@ freezeFineGrainedConflicts :: Flag FineGrainedConflicts, freezeMinimizeConflictSet :: Flag MinimizeConflictSet, freezeIndependentGoals :: Flag IndependentGoals, + freezePreferOldest :: Flag PreferOldest, freezeShadowPkgs :: Flag ShadowPkgs, freezeStrongFlags :: Flag StrongFlags, freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls, @@ -1068,6 +1082,7 @@ freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), freezeIndependentGoals = Flag (IndependentGoals False), + freezePreferOldest = Flag (PreferOldest False), freezeShadowPkgs = Flag (ShadowPkgs False), freezeStrongFlags = Flag (StrongFlags False), freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False), @@ -1122,6 +1137,7 @@ freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) + freezePreferOldest (\v flags -> flags { freezePreferOldest = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v }) freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v }) freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v }) @@ -1264,7 +1280,7 @@ commandSynopsis = "Upload build reports to a remote server.", commandDescription = Nothing, commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n", + "You can store your Hackage login in the ~/.config/cabal/config file\n", commandUsage = usageAlternatives "report" ["[FLAGS]"], commandDefaultFlags = defaultReportFlags, commandOptions = \_ -> @@ -1297,6 +1313,7 @@ data GetFlags = GetFlags { getDestDir :: Flag FilePath, + getOnlyPkgDescr :: Flag Bool, getPristine :: Flag Bool, getIndexState :: Flag TotalIndexState, getActiveRepos :: Flag ActiveRepos, @@ -1307,6 +1324,7 @@ defaultGetFlags :: GetFlags defaultGetFlags = GetFlags { getDestDir = mempty, + getOnlyPkgDescr = mempty, getPristine = mempty, getIndexState = mempty, getActiveRepos = mempty, @@ -1352,6 +1370,16 @@ (toFlag `fmap` parsec)) (flagToList . fmap prettyShow)) + , option [] ["only-package-description"] + "Unpack only the package description file." + getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v }) + trueArg + + , option [] ["package-description-only"] + "A synonym for --only-package-description." + getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v }) + trueArg + , option [] ["pristine"] ("Unpack the original pristine tarball, rather than updating the " ++ ".cabal file with the latest revision from the package archive.") @@ -1556,6 +1584,7 @@ installFineGrainedConflicts :: Flag FineGrainedConflicts, installMinimizeConflictSet :: Flag MinimizeConflictSet, installIndependentGoals :: Flag IndependentGoals, + installPreferOldest :: Flag PreferOldest, installShadowPkgs :: Flag ShadowPkgs, installStrongFlags :: Flag StrongFlags, installAllowBootLibInstalls :: Flag AllowBootLibInstalls, @@ -1598,6 +1627,7 @@ installFineGrainedConflicts = Flag (FineGrainedConflicts True), installMinimizeConflictSet = Flag (MinimizeConflictSet False), installIndependentGoals= Flag (IndependentGoals False), + installPreferOldest = Flag (PreferOldest False), installShadowPkgs = Flag (ShadowPkgs False), installStrongFlags = Flag (StrongFlags False), installAllowBootLibInstalls = Flag (AllowBootLibInstalls False), @@ -1657,7 +1687,7 @@ ++ " `v1-configure` for a list of commands being affected.\n" ++ "\n" ++ "Installed executables will by default" - ++ " be put into `~/.cabal/bin/`." + ++ " be put into `~/.local/bin/`." ++ " If you want installed executable to be available globally, make" ++ " sure that the PATH environment variable contains that directory.\n" ++ "\n", @@ -1749,7 +1779,7 @@ , name `elem` ["hoogle", "html", "html-location" ,"executables", "tests", "benchmarks", "all", "internal", "css" ,"hyperlink-source", "quickjump", "hscolour-css" - ,"contents-location", "for-hackage"] + ,"contents-location", "use-index", "for-hackage", "base-url", "lib"] ] testOptions :: ShowOrParseArgs -> [OptionField TestFlags] @@ -1823,6 +1853,7 @@ installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) + installPreferOldest (\v flags -> flags { installPreferOldest = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) installStrongFlags (\v flags -> flags { installStrongFlags = v }) installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v }) @@ -1978,7 +2009,7 @@ commandSynopsis = "Uploads source packages or documentation to Hackage.", commandDescription = Nothing, commandNotes = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n" + "You can store your Hackage login in the ~/.config/cabal/config file\n" ++ relevantConfigValuesText ["username", "password", "password-command"], commandUsage = \pname -> "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n", @@ -2137,12 +2168,14 @@ , option ['x'] ["extra-source-file"] "Extra source file to be distributed with tarball." - IT.extraSrc (\v flags -> flags { IT.extraSrc = v }) + IT.extraSrc + (\v flags -> flags { IT.extraSrc = mergeListFlag (IT.extraSrc flags) v }) (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault [])) , option [] ["extra-doc-file"] "Extra doc file to be distributed with tarball." - IT.extraDoc (\v flags -> flags { IT.extraDoc = v }) + IT.extraDoc + (\v flags -> flags { IT.extraDoc = mergeListFlag (IT.extraDoc flags) v }) (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault [])) , option [] ["lib", "is-library"] @@ -2170,7 +2203,8 @@ , option [] ["test-dir"] "Directory containing tests." - IT.testDirs (\v flags -> flags { IT.testDirs = v }) + IT.testDirs (\v flags -> + flags { IT.testDirs = mergeListFlag (IT.testDirs flags) v }) (reqArg' "DIR" (Flag . (:[])) (fromFlagOrDefault [])) @@ -2197,7 +2231,8 @@ , option ['o'] ["expose-module"] "Export a module from the package." IT.exposedModules - (\v flags -> flags { IT.exposedModules = v }) + (\v flags -> flags { IT.exposedModules = + mergeListFlag (IT.exposedModules flags) v}) (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++) (Flag . (:[]) <$> parsec)) (flagElim [] (fmap prettyShow))) @@ -2205,33 +2240,38 @@ , option [] ["extension"] "Use a LANGUAGE extension (in the other-extensions field)." IT.otherExts - (\v flags -> flags { IT.otherExts = v }) + (\v flags -> flags { IT.otherExts = + mergeListFlag (IT.otherExts flags) v }) (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++) (Flag . (:[]) <$> parsec)) (flagElim [] (fmap prettyShow))) , option ['d'] ["dependency"] - "Package dependency." - IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++) - (Flag . (:[]) <$> parsec)) - (flagElim [] (fmap prettyShow))) + "Package dependencies. Permits comma separated list of dependencies." + IT.dependencies + (\v flags -> flags { IT.dependencies = + mergeListFlag (IT.dependencies flags) v }) + (reqArg "DEPENDENCIES" (fmap Flag dependenciesReadE) + (fmap prettyShow . fromFlagOrDefault [])) , option [] ["application-dir"] "Directory containing package application executable." - IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v}) + IT.applicationDirs (\v flags -> flags { IT.applicationDirs = + mergeListFlag (IT.applicationDirs flags) v}) (reqArg' "DIR" (Flag . (:[])) (fromFlagOrDefault [])) , option [] ["source-dir", "sourcedir"] "Directory containing package library source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = + mergeListFlag (IT.sourceDirs flags) v }) (reqArg' "DIR" (Flag. (:[])) (fromFlagOrDefault [])) , option [] ["build-tool"] "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = v }) + IT.buildTools (\v flags -> flags { IT.buildTools = + mergeListFlag (IT.buildTools flags) v }) (reqArg' "TOOL" (Flag . (:[])) (fromFlagOrDefault [])) @@ -2243,7 +2283,17 @@ , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) ] + where + dependenciesReadE :: ReadE [Dependency] + dependenciesReadE = + parsecToReadE + ("Cannot parse dependencies: " ++) + (parsecCommaList parsec) + mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a] + mergeListFlag currentFlags v = + Flag $ concat (flagToList currentFlags ++ flagToList v) + -- ------------------------------------------------------------ -- * Copy and Register -- ------------------------------------------------------------ @@ -2333,18 +2383,18 @@ commandDescription = Just $ \_ -> wrapText $ "When upgrading cabal, the set of configuration keys and their default" ++ " values may change. This command provides means to merge the existing" - ++ " config in ~/.cabal/config" + ++ " config in ~/.config/cabal/config" ++ " (i.e. all bindings that are actually defined and not commented out)" ++ " and the default config of the new version.\n" ++ "\n" - ++ "init: Creates a new config file at either ~/.cabal/config or as" + ++ "init: Creates a new config file at either ~/.config/cabal/config or as" ++ " specified by --config-file, if given. An existing file won't be " ++ " overwritten unless -f or --force is given.\n" - ++ "diff: Shows a pseudo-diff of the user's ~/.cabal/config file and" + ++ "diff: Shows a pseudo-diff of the user's ~/.config/cabal/config file and" ++ " the default configuration that would be created by cabal if the" ++ " config file did not exist.\n" ++ "update: Applies the pseudo-diff to the configuration that would be" - ++ " created by default, and write the result back to ~/.cabal/config.", + ++ " created by default, and write the result back to ~/.config/cabal/config.", commandNotes = Nothing, commandUsage = usageAlternatives "user-config" ["init", "diff", "update"], @@ -2399,13 +2449,14 @@ -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) + -> (flags -> Flag PreferOldest) -> (Flag PreferOldest -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags) -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags) -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags) -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) -> [OptionField flags] optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc - getfgc setfgc getmc setmc getig setig getsip setsip + getfgc setfgc getmc setmc getig setig getpo setpo getsip setsip getstrfl setstrfl getib setib getoc setoc = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") @@ -2438,6 +2489,11 @@ "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen." (fmap asBool . getig) (setig . fmap IndependentGoals) + (yesNoOpt showOrParseArgs) + , option [] ["prefer-oldest"] + "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section." + (fmap asBool . getpo) + (setpo . fmap PreferOldest) (yesNoOpt showOrParseArgs) , option [] ["shadow-installed-packages"] "If multiple package instances of the same version are installed, treat all but one as shadowed." diff --git a/src/Distribution/Client/SetupWrapper.hs b/src/Distribution/Client/SetupWrapper.hs --- a/src/Distribution/Client/SetupWrapper.hs +++ b/src/Distribution/Client/SetupWrapper.hs @@ -77,7 +77,7 @@ import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Client.Types import Distribution.Client.Config - ( getCabalDir ) + ( defaultCacheDir ) import Distribution.Client.IndexUtils ( getInstalledPackages ) import Distribution.Client.JobControl @@ -87,8 +87,8 @@ import Distribution.Utils.Generic ( safeHead ) import Distribution.Simple.Utils - ( die', debug, info, infoNoWrap - , cabalVersion, tryFindPackageDesc + ( die', debug, info, infoNoWrap, maybeExit + , cabalVersion, tryFindPackageDesc, rawSystemProc , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFileEx, rewriteFileLBS ) import Distribution.Client.Utils @@ -109,9 +109,8 @@ import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>) ) import System.IO ( Handle, hPutStr ) -import Distribution.Compat.Process (createProcess) -import System.Process ( StdStream(..), proc, waitForProcess - , ProcessHandle ) +import Distribution.Compat.Process (proc) +import System.Process ( StdStream(..) ) import qualified System.Process as Process import Data.List ( foldl1' ) import Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) @@ -241,7 +240,7 @@ -- When we are installing in parallel, we always use the external setup -- method. Since compiling the setup script each time adds noticeable -- overhead, we use a shared setup script cache - -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal + -- ('$XDG_CACHE_HOME/cabal/setup-exe-cache'). For each (compiler, platform, Cabal -- version) combination the cache holds a compiled setup script -- executable. This only affects the Simple build type; for the Custom, -- Configure and Make build types we always compile the setup script anew. @@ -437,35 +436,32 @@ buildTypeAction Make = Make.defaultMainArgs buildTypeAction Custom = error "buildTypeAction Custom" +invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO () +invoke verbosity path args options = do + info verbosity $ unwords (path : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle --- | @runProcess'@ is a version of @runProcess@ where we have --- the additional option to decide whether or not we should --- delegate CTRL+C to the spawned process. -runProcess' :: FilePath -- ^ Filename of the executable - -> [String] -- ^ Arguments to pass to executable - -> Maybe FilePath -- ^ Optional path to working directory - -> Maybe [(String, String)] -- ^ Optional environment - -> Maybe Handle -- ^ Handle for @stdin@ - -> Maybe Handle -- ^ Handle for @stdout@ - -> Maybe Handle -- ^ Handle for @stderr@ - -> Bool -- ^ Delegate Ctrl+C ? - -> IO ProcessHandle -runProcess' cmd args mb_cwd mb_env mb_stdin mb_stdout mb_stderr _delegate = do - (_,_,_,ph) <- - createProcess - (proc cmd args){ Process.cwd = mb_cwd - , Process.env = mb_env - , Process.std_in = mbToStd mb_stdin - , Process.std_out = mbToStd mb_stdout - , Process.std_err = mbToStd mb_stderr - , Process.delegate_ctlc = _delegate - } - return ph - where - mbToStd :: Maybe Handle -> StdStream - mbToStd Nothing = Inherit - mbToStd (Just hdl) = UseHandle hdl + searchpath <- programSearchPathAsPATHVar + (map ProgramSearchPathDir (useExtraPathEnv options) ++ + getProgramSearchPath (useProgramDb options)) + env <- getEffectiveEnvironment $ + [ ("PATH", Just searchpath) + , ("HASKELL_DIST_DIR", Just (useDistPref options)) + ] ++ useExtraEnvOverrides options + let loggingHandle = case useLoggingHandle options of + Nothing -> Inherit + Just hdl -> UseHandle hdl + cp = (proc path args) { Process.cwd = useWorkingDir options + , Process.env = env + , Process.std_out = loggingHandle + , Process.std_err = loggingHandle + , Process.delegate_ctlc = isInteractive options + } + maybeExit $ rawSystemProc verbosity cp + -- ------------------------------------------------------------ -- * Self-Exec SetupMethod -- ------------------------------------------------------------ @@ -478,83 +474,43 @@ info verbosity $ "Using self-exec internal setup method with build-type " ++ show bt ++ " and args:\n " ++ show args path <- getExecutablePath - info verbosity $ unwords (path : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options - process <- runProcess' path args - (useWorkingDir options) env Nothing - (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode + invoke verbosity path args options -- ------------------------------------------------------------ -- * External SetupMethod -- ------------------------------------------------------------ externalSetupMethod :: WithCallStack (FilePath -> SetupRunner) -externalSetupMethod path verbosity options _ args = do - info verbosity $ unwords (path : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - - -- See 'Note: win32 clean hack' above. -#ifdef mingw32_HOST_OS - if useWin32CleanHack options then doWin32CleanHack path else doInvoke path +externalSetupMethod path verbosity options _ args = +#ifndef mingw32_HOST_OS + invoke verbosity path args options #else - doInvoke path -#endif - + -- See 'Note: win32 clean hack' above. + if useWin32CleanHack options + then invokeWithWin32CleanHack path + else invoke' path where - doInvoke path' = do - searchpath <- programSearchPathAsPATHVar - (map ProgramSearchPathDir (useExtraPathEnv options) ++ - getProgramSearchPath (useProgramDb options)) - env <- getEffectiveEnvironment $ - [ ("PATH", Just searchpath) - , ("HASKELL_DIST_DIR", Just (useDistPref options)) - ] ++ useExtraEnvOverrides options - - debug verbosity $ "Setup arguments: "++unwords args - process <- runProcess' path' args - (useWorkingDir options) env Nothing - (useLoggingHandle options) (useLoggingHandle options) - (isInteractive options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode + invoke' p = invoke verbosity p args options -#ifdef mingw32_HOST_OS - doWin32CleanHack path' = do + invokeWithWin32CleanHack origPath = do info verbosity $ "Using the Win32 clean hack." -- Recursively removes the temp dir on exit. withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir -> - bracket (moveOutOfTheWay tmpDir path') - (maybeRestore path') - doInvoke + bracket (moveOutOfTheWay tmpDir origPath) + (\tmpPath -> maybeRestore origPath tmpPath) + (\tmpPath -> invoke' tmpPath) - moveOutOfTheWay tmpDir path' = do - let newPath = tmpDir "setup" <.> exeExtension buildPlatform - Win32.moveFile path' newPath - return newPath + moveOutOfTheWay tmpDir origPath = do + let tmpPath = tmpDir "setup" <.> exeExtension buildPlatform + Win32.moveFile origPath tmpPath + return tmpPath - maybeRestore oldPath path' = do - let oldPathDir = takeDirectory oldPath - oldPathDirExists <- doesDirectoryExist oldPathDir + maybeRestore origPath tmpPath = do + let origPathDir = takeDirectory origPath + origPathDirExists <- doesDirectoryExist origPathDir -- 'setup clean' didn't complete, 'dist/setup' still exists. - when oldPathDirExists $ - Win32.moveFile path' oldPath + when origPathDirExists $ + Win32.moveFile tmpPath origPath #endif getExternalSetupMethod @@ -784,8 +740,8 @@ cachedSetupDirAndProg :: SetupScriptOptions -> Version -> IO (FilePath, FilePath) cachedSetupDirAndProg options' cabalLibVersion = do - cabalDir <- getCabalDir - let setupCacheDir = cabalDir "setup-exe-cache" + cacheDir <- defaultCacheDir + let setupCacheDir = cacheDir "setup-exe-cache" cachedSetupProgFile = setupCacheDir ("setup-" ++ buildTypeString ++ "-" ++ cabalVersionString ++ "-" diff --git a/src/Distribution/Client/Signal.hs b/src/Distribution/Client/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Client/Signal.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +module Distribution.Client.Signal + ( installTerminationHandler + , Terminated(..) + ) +where + +import qualified Control.Exception as Exception + +#ifndef mingw32_HOST_OS +import Control.Concurrent (myThreadId) +import Control.Monad (void) +import qualified System.Posix.Signals as Signals +#endif + +-- | Terminated is an asynchronous exception, thrown when +-- SIGTERM is received. It's to 'kill' what 'UserInterrupt' +-- is to Ctrl-C. +data Terminated = Terminated + +instance Exception.Exception Terminated where + toException = Exception.asyncExceptionToException + fromException = Exception.asyncExceptionFromException + +instance Show Terminated where + show Terminated = "terminated" + +-- | Install a signal handler that initiates a controlled shutdown on receiving +-- SIGTERM by throwing an asynchronous exception at the main thread. Must be +-- called from the main thread. +-- +-- It is a noop on Windows. +-- +installTerminationHandler :: IO () + +#ifdef mingw32_HOST_OS + +installTerminationHandler = return () + +#else + +installTerminationHandler = do + mainThreadId <- myThreadId + void $ Signals.installHandler + Signals.sigTERM + (Signals.CatchOnce $ Exception.throwTo mainThreadId Terminated) + Nothing + +#endif diff --git a/src/Distribution/Client/SourceFiles.hs b/src/Distribution/Client/SourceFiles.hs --- a/src/Distribution/Client/SourceFiles.hs +++ b/src/Distribution/Client/SourceFiles.hs @@ -39,7 +39,7 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Distribution.Verbosity (silent) +import Distribution.Verbosity (normal) import System.FilePath @@ -150,7 +150,8 @@ -- A.hs-boot; need to track both. findNeededModules ["hs", "lhs", "hsig", "lhsig"] findNeededModules ["hs-boot", "lhs-boot"] - expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie silent (\ _ _ -> return []) (specVersion pkg_descr) "." fpath + root <- askRoot + expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie normal (\ _ _ -> return []) (specVersion pkg_descr) root fpath traverse_ needIfExists $ concat [ cSources bi , cxxSources bi diff --git a/src/Distribution/Client/TargetSelector.hs b/src/Distribution/Client/TargetSelector.hs --- a/src/Distribution/Client/TargetSelector.hs +++ b/src/Distribution/Client/TargetSelector.hs @@ -713,21 +713,26 @@ case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of [] -> return () ((target, originalMatch, renderingsAndMatches):_) -> - die' verbosity $ "Internal error in target matching. It should always " - ++ "be possible to find a syntax that's sufficiently qualified to " - ++ "give an unambiguous match. However when matching '" - ++ showTargetString target ++ "' we found " - ++ showTargetSelector originalMatch - ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " - ++ "not have an unambiguous syntax. The possible syntax and the " - ++ "targets they match are as follows:\n" + die' verbosity $ "Internal error in target matching: could not make an " + ++ "unambiguous fully qualified target selector for '" + ++ showTargetString target ++ "'.\n" + ++ "We made the target '" ++ showTargetSelector originalMatch ++ "' (" + ++ showTargetSelectorKind originalMatch ++ ") that was expected to " + ++ "be unambiguous but matches the following targets:\n" ++ unlines - [ "'" ++ showTargetString rendering ++ "' which matches " - ++ intercalate ", " + [ "'" ++ showTargetString rendering ++ "', matching:" + ++ concatMap ("\n - " ++) [ showTargetSelector match ++ " (" ++ showTargetSelectorKind match ++ ")" | match <- matches ] | (rendering, matches) <- renderingsAndMatches ] + ++ "\nNote: Cabal expects to be able to make a single fully " + ++ "qualified name for a target or provide a more specific error. " + ++ "Our failure to do so is a bug in cabal. " + ++ "Tracking issue: https://github.com/haskell/cabal/issues/8684" + ++ "\n\nHint: this may be caused by trying to build a package that " + ++ "exists in the project directory but is missing from " + ++ "the 'packages' stanza in your cabal project file." case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of [] -> return () diff --git a/src/Distribution/Client/Types/ConfiguredPackage.hs b/src/Distribution/Client/Types/ConfiguredPackage.hs --- a/src/Distribution/Client/Types/ConfiguredPackage.hs +++ b/src/Distribution/Client/Types/ConfiguredPackage.hs @@ -82,5 +82,3 @@ instance PackageInstalled (ConfiguredPackage loc) where installedDepends = CD.flatDeps . depends - - diff --git a/src/Distribution/Client/Upload.hs b/src/Distribution/Client/Upload.hs --- a/src/Distribution/Client/Upload.hs +++ b/src/Distribution/Client/Upload.hs @@ -183,9 +183,9 @@ let auth :: (String, String) auth = (username, password) - dotCabal <- getCabalDir + reportsDir <- defaultReportsDir let srcDir :: FilePath - srcDir = dotCabal "reports" unRepoName (remoteRepoName remoteRepo) + srcDir = reportsDir unRepoName (remoteRepoName remoteRepo) -- We don't want to bomb out just because we haven't built any packages -- from this repo yet. srcExists <- doesDirectoryExist srcDir diff --git a/src/Distribution/Client/Utils.hs b/src/Distribution/Client/Utils.hs --- a/src/Distribution/Client/Utils.hs +++ b/src/Distribution/Client/Utils.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, CPP #-} +{-# LANGUAGE ScopedTypeVariables, CPP #-} module Distribution.Client.Utils ( MergeResult(..) @@ -28,6 +28,7 @@ , listFilesRecursive , listFilesInside , safeRead + , hasElem ) where import Prelude () @@ -47,7 +48,6 @@ ( zipWithM_ ) import Data.List ( groupBy ) -import Foreign.C.Types ( CInt(..) ) import qualified Control.Exception as Exception ( finally ) import qualified Control.Exception.Safe as Safe @@ -61,6 +61,7 @@ ) import System.IO.Unsafe ( unsafePerformIO ) +import GHC.Conc.Sync ( getNumProcessors ) import GHC.IO.Encoding ( recover, TextEncoding(TextEncoding) ) import GHC.IO.Encoding.Failure @@ -73,7 +74,7 @@ import qualified System.Directory as Dir import qualified System.IO.Error as IOError #endif - +import qualified Data.Set as Set -- | Generic merging utility. For sorted input lists this is a full outer join. -- @@ -145,9 +146,7 @@ withEnv k v m = do mb_old <- lookupEnv k setEnv k v - m `Exception.finally` (case mb_old of - Nothing -> unsetEnv k - Just old -> setEnv k old) + m `Exception.finally` setOrUnsetEnv k mb_old -- | Executes the action with a list of environment variables and -- corresponding overrides, where @@ -160,15 +159,15 @@ withEnvOverrides :: [(String, Maybe FilePath)] -> IO a -> IO a withEnvOverrides overrides m = do mb_olds <- traverse lookupEnv envVars - traverse_ (uncurry update) overrides - m `Exception.finally` zipWithM_ update envVars mb_olds + traverse_ (uncurry setOrUnsetEnv) overrides + m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds where envVars :: [String] envVars = map fst overrides - update :: String -> Maybe FilePath -> IO () - update var Nothing = unsetEnv var - update var (Just val) = setEnv var val +setOrUnsetEnv :: String -> Maybe String -> IO () +setOrUnsetEnv var Nothing = unsetEnv var +setOrUnsetEnv var (Just val) = setEnv var val -- | Executes the action, increasing the PATH environment -- in some way @@ -197,12 +196,10 @@ m `Exception.finally` (l $ "cabal: Leaving directory '" ++ d ++ "'\n") -foreign import ccall "getNumberOfProcessors" c_getNumberOfProcessors :: IO CInt - -- The number of processors is not going to change during the duration of the -- program, so unsafePerformIO is safe here. numberOfProcessors :: Int -numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors +numberOfProcessors = unsafePerformIO getNumProcessors -- | Determine the number of jobs to use given the value of the '-j' flag. determineNumJobs :: Flag (Maybe Int) -> Int @@ -433,7 +430,7 @@ -- | From System.Directory.Extra -- https://hackage.haskell.org/package/extra-1.7.9 listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath] -listFilesInside test dir = ifM (notM $ test $ dropTrailingPathSeparator dir) (pure []) $ do +listFilesInside test dir = ifNotM (test $ dropTrailingPathSeparator dir) (pure []) $ do (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir rest <- concatMapM (listFilesInside test) dirs pure $ files ++ rest @@ -455,6 +452,11 @@ ifM :: Monad m => m Bool -> m a -> m a -> m a ifM b t f = do b' <- b; if b' then t else f +-- | 'ifM' with swapped branches: +-- @ifNotM b t f = ifM (not <$> b) t f@ +ifNotM :: Monad m => m Bool -> m a -> m a -> m a +ifNotM = flip . ifM + -- | From Control.Monad.Extra -- https://hackage.haskell.org/package/extra-1.7.9 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] @@ -471,12 +473,18 @@ (as,bs) <- partitionM f xs pure ([x | res]++as, [x | not res]++bs) --- | From Control.Monad.Extra --- https://hackage.haskell.org/package/extra-1.7.9 -notM :: Functor m => m Bool -> m Bool -notM = fmap not - safeRead :: Read a => String -> Maybe a safeRead s | [(x, "")] <- reads s = Just x | otherwise = Nothing + +-- | @hasElem xs x = elem x xs@ except that @xs@ is turned into a 'Set' first. +-- Use underapplied to speed up subsequent lookups, e.g. @filter (hasElem xs) ys@. +-- Only amortized when used several times! +-- +-- Time complexity \(O((n+m) \log(n))\) for \(m\) lookups in a list of length \(n\). +-- (Compare this to 'elem''s \(O(nm)\).) +-- +-- This is [Agda.Utils.List.hasElem](https://hackage.haskell.org/package/Agda-2.6.2.2/docs/Agda-Utils-List.html#v:hasElem). +hasElem :: Ord a => [a] -> a -> Bool +hasElem xs = (`Set.member` Set.fromList xs) diff --git a/src/Distribution/Client/VCS.hs b/src/Distribution/Client/VCS.hs --- a/src/Distribution/Client/VCS.hs +++ b/src/Distribution/Client/VCS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} @@ -53,8 +54,11 @@ ( mkVersion ) import qualified Distribution.PackageDescription as PD +#if !MIN_VERSION_base(4,18,0) import Control.Applicative ( liftA2 ) +#endif + import Control.Exception ( throw, try ) import Control.Monad.Trans @@ -205,7 +209,7 @@ srcuri destdir --- | Syncronise a set of 'SourceRepo's referring to the same repository with +-- | Synchronise a set of 'SourceRepo's referring to the same repository with -- corresponding local directories. The local directories may or may not -- already exist. -- @@ -654,7 +658,7 @@ -- -- -- -----> foo on branch B -----> --- resolve confict Initial patch +-- resolve conflict Initial patch -- -----> foo on branch A -----> -- -- Which is seems reasonable. diff --git a/src/Distribution/Client/Version.hs b/src/Distribution/Client/Version.hs --- a/src/Distribution/Client/Version.hs +++ b/src/Distribution/Client/Version.hs @@ -7,10 +7,10 @@ import Distribution.Version -- This value determines the `cabal-install --version` output. --- --- It is used in several places throughout the project, including anonymous build reports, client configuration, --- and project planning output. Historically, this was a @Paths_*@ module, however, this conflicted with --- program coverage information generated by HPC, and hence was moved to be a standalone value. -- +-- It is used in several places throughout the project, including anonymous build reports, client configuration, +-- and project planning output. Historically, this was a @Paths_*@ module, however, this conflicted with +-- program coverage information generated by HPC, and hence was moved to be a standalone value. +-- cabalInstallVersion :: Version -cabalInstallVersion = mkVersion [3,8,1,0] +cabalInstallVersion = mkVersion [3,10,1,0] diff --git a/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/src/Distribution/Deprecated/ViewAsFieldDescr.hs --- a/src/Distribution/Deprecated/ViewAsFieldDescr.hs +++ b/src/Distribution/Deprecated/ViewAsFieldDescr.hs @@ -81,4 +81,3 @@ getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" - diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs --- a/tests/IntegrationTests2.hs +++ b/tests/IntegrationTests2.hs @@ -15,7 +15,6 @@ import Distribution.Client.DistDirLayout import Distribution.Client.ProjectConfig -import Distribution.Client.Config (getCabalDir) import Distribution.Client.HttpUtils import Distribution.Client.TargetSelector hiding (DirActions(..)) import qualified Distribution.Client.TargetSelector as TS (DirActions(..)) @@ -51,6 +50,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) import Distribution.Client.Setup (globalCommand) +import Distribution.Client.Config (loadConfig, SavedConfig(savedGlobalFlags)) import Distribution.Simple.Compiler import Distribution.Simple.Command import qualified Distribution.Simple.Flag as Flag @@ -1678,8 +1678,7 @@ configureProject :: FilePath -> ProjectConfig -> IO ProjDetails configureProject testdir cliConfig = do - cabalDir <- getCabalDir - let cabalDirLayout = defaultCabalDirLayout cabalDir + cabalDirLayout <- defaultCabalDirLayout projectRootDir <- canonicalizePath (basedir testdir) isexplict <- doesFileExist (projectRootDir "cabal.project") @@ -1730,6 +1729,7 @@ distDirLayout cabalDirLayout projectConfig localPackages + Nothing return (projDetails, elaboratedPlan, @@ -1956,6 +1956,15 @@ Just True @=? (fromFlag . globalNix . fromJust $ nixEnabledFlags) Just False @=? (fromFlag . globalNix . fromJust $ nixDisabledFlags) Nothing @=? (fromFlag . globalNix . fromJust $ nixDefaultFlags) + + -- Config file options + defaultConfig <- loadConfig verbosity (Flag (basedir "nix-config/default-config")) + trueConfig <- loadConfig verbosity (Flag (basedir "nix-config/nix-true")) + falseConfig <- loadConfig verbosity (Flag (basedir "nix-config/nix-false")) + + Nothing @=? (fromFlag . globalNix . savedGlobalFlags $ defaultConfig) + Just True @=? (fromFlag . globalNix . savedGlobalFlags $ trueConfig) + Just False @=? (fromFlag . globalNix . savedGlobalFlags $ falseConfig) where fromFlag :: Flag Bool -> Maybe Bool fromFlag (Flag x) = Just x diff --git a/tests/UnitTests/Distribution/Client/Configure.hs b/tests/UnitTests/Distribution/Client/Configure.hs --- a/tests/UnitTests/Distribution/Client/Configure.hs +++ b/tests/UnitTests/Distribution/Client/Configure.hs @@ -18,26 +18,26 @@ import Distribution.Simple.Flag tests :: [TestTree] -tests = +tests = [ configureTests ] configureTests :: TestTree configureTests = testGroup "Configure tests" [ testCase "New config" $ do - let flags = (defaultNixStyleFlags ()) + let flags = (defaultNixStyleFlags ()) { configFlags = mempty { configOptimization = Flag MaximumOptimisation , configVerbosity = Flag silent } } projConfig <- configureAction' flags [] defaultGlobalFlags - + Flag MaximumOptimisation @=? (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig) , testCase "Replacement + new config" $ do - let flags = (defaultNixStyleFlags ()) + let flags = (defaultNixStyleFlags ()) { configExFlags = mempty { configAppend = Flag True } , configFlags = mempty @@ -51,9 +51,9 @@ Flag NoOptimisation @=? packageConfigOptimization projectConfigLocalPackages Flag silent @=? projectConfigVerbosity projectConfigBuildOnly - + , testCase "Old + new config" $ do - let flags = (defaultNixStyleFlags ()) + let flags = (defaultNixStyleFlags ()) { configExFlags = mempty { configAppend = Flag True } , configFlags = mempty @@ -65,9 +65,9 @@ Flag MaximumOptimisation @=? packageConfigOptimization projectConfigLocalPackages Flag silent @=? projectConfigVerbosity projectConfigBuildOnly - + , testCase "Old + new config, no appending" $ do - let flags = (defaultNixStyleFlags ()) + let flags = (defaultNixStyleFlags ()) { configFlags = mempty { configVerbosity = Flag silent } , projectFlags = mempty @@ -77,9 +77,9 @@ NoFlag @=? packageConfigOptimization projectConfigLocalPackages Flag silent @=? projectConfigVerbosity projectConfigBuildOnly - + , testCase "Old + new config, backup check" $ do - let flags = (defaultNixStyleFlags ()) + let flags = (defaultNixStyleFlags ()) { configFlags = mempty { configVerbosity = Flag silent } , projectFlags = mempty @@ -88,7 +88,7 @@ backup = projectFile <.> "local~" exists <- doesFileExist backup - when exists $ + when exists $ removeFile backup _ <- configureAction' flags [] defaultGlobalFlags diff --git a/tests/UnitTests/Distribution/Client/Get.hs b/tests/UnitTests/Distribution/Client/Get.hs --- a/tests/UnitTests/Distribution/Client/Get.hs +++ b/tests/UnitTests/Distribution/Client/Get.hs @@ -39,7 +39,7 @@ , askOption $ \(RunNetworkTests doRunNetTests) -> testGroup "forkPackages, network tests" $ includeTestsIf doRunNetTests $ - [ testCase "git clone" testNetworkGitClone + [ testCase "git clone" testNetworkGitClone ] ] where @@ -234,7 +234,7 @@ case r of Left e -> return e Right _ -> assertFailure $ "expected exception of type " - ++ show (typeOf (undefined :: e)) + ++ show (typeOf (undefined :: e)) -- | Expect that one line in a file matches exactly the given words (i.e. at diff --git a/tests/UnitTests/Distribution/Client/IndexUtils.hs b/tests/UnitTests/Distribution/Client/IndexUtils.hs --- a/tests/UnitTests/Distribution/Client/IndexUtils.hs +++ b/tests/UnitTests/Distribution/Client/IndexUtils.hs diff --git a/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/tests/UnitTests/Distribution/Client/Init/FileCreators.hs --- a/tests/UnitTests/Distribution/Client/Init/FileCreators.hs +++ b/tests/UnitTests/Distribution/Client/Init/FileCreators.hs @@ -18,7 +18,7 @@ import Distribution.Simple.PackageIndex import Distribution.Verbosity -tests +tests :: Verbosity -> InitFlags -> Compiler @@ -82,6 +82,6 @@ Left (BreakException ex) -> assertFailure $ show ex Right _ -> return () - + ] diff --git a/tests/UnitTests/Distribution/Client/Init/Golden.hs b/tests/UnitTests/Distribution/Client/Init/Golden.hs --- a/tests/UnitTests/Distribution/Client/Init/Golden.hs +++ b/tests/UnitTests/Distribution/Client/Init/Golden.hs @@ -68,7 +68,7 @@ pkgDir = evalPrompt (getPackageDir initFlags) $ fromList ["."] pkgName = evalPrompt (packageNamePrompt srcDb initFlags) - $ fromList ["test-package", "y"] + $ fromList ["test-package", "test-package", "y"] goldenPkgDescTests :: Verbosity @@ -215,7 +215,7 @@ (goldenTest "test-build-tools-with-comments.golden") $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion in runGoldenTest opts testArgs (emptyFlags {buildTools = Flag ["happy"]}) - + , goldenVsString "Standalone tests, empty flags, not simple, no options, no comments" (goldenTest "standalone-test-no-comments.golden") $ let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion @@ -256,7 +256,7 @@ , goldenVsString "Library, empty flags, not simple, no comments + no minimal" (goldenCabal "cabal-lib-no-comments.golden") $ runGoldenTest (libProjArgs "N") emptyFlags - + , goldenVsString "Test suite, empty flags, not simple, with comments + no minimal" (goldenCabal "cabal-test-suite-with-comments.golden") $ runGoldenTest (testProjArgs "Y") emptyFlags @@ -286,12 +286,12 @@ testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} mkStanza $ pkgFields ++ [commonStanza, libStanza, testStanza] - + (Right (ProjectSettings opts pkgDesc Nothing Nothing (Just testTarget), _)) -> do let pkgFields = mkPkgDescription opts pkgDesc commonStanza = mkCommonStanza opts testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies} - + mkStanza $ pkgFields ++ [commonStanza, testStanza] (Right (ProjectSettings _ _ l e t, _)) -> assertFailure $ @@ -336,6 +336,7 @@ pkgArgs :: NonEmpty String pkgArgs = fromList [ "5" + , "foo-package" , "foo-package" , "y" , "0.1.0.0" diff --git a/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/tests/UnitTests/Distribution/Client/Init/Interactive.hs --- a/tests/UnitTests/Distribution/Client/Init/Interactive.hs +++ b/tests/UnitTests/Distribution/Client/Init/Interactive.hs @@ -140,6 +140,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -246,6 +247,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -322,7 +324,7 @@ exe @?= Nothing test @?! Nothing Left e -> assertFailure $ show e - + , testCase "Check the interactive library workflow" $ do let inputs = fromList -- package type @@ -337,6 +339,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -415,6 +418,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -507,6 +511,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -584,6 +589,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -667,6 +673,7 @@ -- package name , "test-package" , "test-package" + , "test-package" -- version , "3.1.2.3" -- license @@ -739,6 +746,7 @@ let inputs = fromList [ "1" -- pick the first cabal version in the list , "my-test-package" -- package name + , "my-test-package" -- current dir for the purpose of guessing the package name , "y" -- "yes to prompt internal to package name" , "0.2.0.1" -- package version , "2" -- pick the second license in the list @@ -796,15 +804,18 @@ (packageNamePrompt srcDb) (mkPackageName "test-package") [ "test-package" , "test-package" + , "test-package" ] , testSimplePrompt "New package name 2" (packageNamePrompt srcDb) (mkPackageName "test-package") [ "test-package" + , "test-package" , "" ] , testSimplePrompt "Existing package name 1" (packageNamePrompt srcDb) (mkPackageName "test-package") [ "test-package" + , "test-package" , "cabal-install" , "y" , "test-package" @@ -812,6 +823,7 @@ , testSimplePrompt "Existing package name 2" (packageNamePrompt srcDb) (mkPackageName "cabal-install") [ "test-package" + , "test-package" , "cabal-install" , "n" ] @@ -919,14 +931,13 @@ , "Haskell2022" ] , testSimplePrompt "Invalid language" - (`languagePrompt` "test") Haskell2010 + (`languagePrompt` "test") (UnknownLanguage "Lang_TS!") [ "4" , "Lang_TS!" - , "1" ] ] , testGroup "Check srcDirsPrompt output" - [ testNumberedPrompt "Soruce dirs indices" srcDirsPrompt + [ testNumberedPrompt "Source dirs indices" srcDirsPrompt [[defaultSourceDir], ["lib"], ["src-lib"]] , testSimplePrompt "Other source dir" srcDirsPrompt ["src"] diff --git a/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs --- a/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs +++ b/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module UnitTests.Distribution.Client.Init.NonInteractive ( tests ) where @@ -24,6 +25,8 @@ import qualified Data.Set as Set import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep) import Distribution.FieldGrammar.Newtypes +import Distribution.Simple.Command +import Distribution.Client.Setup (initCommand) tests :: Verbosity @@ -43,6 +46,9 @@ , testGroup "non-interactive tests" [ nonInteractiveTests pkgIx srcDb comp ] + , testGroup "cli parser tests" + [ cliListParserTests + ] ] driverFunctionTest @@ -331,7 +337,7 @@ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags + case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags { initializeTestSuite = Flag True , packageType = Flag LibraryAndExecutable })) inputs of @@ -475,7 +481,7 @@ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]" ] - case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags + case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags { initializeTestSuite = Flag True , packageType = Flag Library })) inputs of @@ -515,7 +521,7 @@ _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards] _testDependencies test @?! [] _testBuildTools test @?= [mkStringyDep "happy:happy"] - + assertBool "The library should be a dependency of the test executable" $ mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test @@ -1265,3 +1271,136 @@ case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of Left x -> g x Right x -> h x + +cliListParserTests :: TestTree +cliListParserTests = testGroup "cli list parser" + [ testCase "Single extraSrc" $ do + flags <- runParserTest ["-x", "Generated.hs"] + flags @?= emptyFlags + { extraSrc = Flag ["Generated.hs"] + } + , testCase "Multiple extraSrc" $ do + flags <- runParserTest ["-x", "Gen1.hs", "-x", "Gen2.hs", "-x", "Gen3.hs"] + flags @?= emptyFlags + { extraSrc = Flag ["Gen1.hs", "Gen2.hs", "Gen3.hs"] + } + , testCase "Single extraDoc" $ do + flags <- runParserTest ["--extra-doc-file", "README"] + flags @?= emptyFlags + { extraDoc = Flag $ ["README"] + } + , testCase "Multiple extraDoc" $ do + flags <- runParserTest ["--extra-doc-file", "README", + "--extra-doc-file", "CHANGELOG", + "--extra-doc-file", "LICENSE"] + flags @?= emptyFlags + { extraDoc = Flag $ map fromString ["README", "CHANGELOG", "LICENSE"] + } + , testCase "Single exposedModules" $ do + flags <- runParserTest ["-o", "Test"] + flags @?= emptyFlags + { exposedModules = Flag $ map fromString ["Test"] + } + , testCase "Multiple exposedModules" $ do + flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"] + flags @?= emptyFlags + { exposedModules = Flag $ map fromString ["Test", "Test2", "Test3"] + } + -- there is no otherModules cli flag + -- , testCase "Single otherModules" $ do + -- flags <- runParserTest ["-o", "Test"] + -- flags @?= dummyFlags + -- { otherModules = Flag $ map fromString ["Test"] + -- } + -- , testCase "Multiple otherModules" $ do + -- flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"] + -- flags @?= dummyFlags + -- { otherModules = Flag $ map fromString ["Test", "Test2", "Test3"] + -- } + , testCase "Single otherExts" $ do + flags <- runParserTest ["--extension", "OverloadedStrings"] + flags @?= emptyFlags + { otherExts = Flag [EnableExtension OverloadedStrings] + } + , testCase "Multiple otherExts" $ do + flags <- runParserTest ["--extension", "OverloadedStrings", + "--extension", "FlexibleInstances", + "--extension", "FlexibleContexts"] + flags @?= emptyFlags + { otherExts = Flag [EnableExtension OverloadedStrings, + EnableExtension FlexibleInstances, + EnableExtension FlexibleContexts] + } + , testCase "Single dependency" $ do + flags <- runParserTest ["-d", "base"] + flags @?= emptyFlags + { dependencies = Flag [mkStringyDep "base"] + } + , testCase "Multiple dependency flags" $ do + flags <- runParserTest ["-d", "base", "-d", "vector"] + flags @?= emptyFlags + { dependencies = Flag $ fmap mkStringyDep ["base", "vector"] + } + , testCase "Comma separated list of dependencies" $ do + flags <- runParserTest ["-d", "base,vector"] + flags @?= emptyFlags + { dependencies = Flag $ fmap mkStringyDep ["base", "vector"] + } + , testCase "Single applicationDirs" $ do + flags <- runParserTest ["--application-dir", "app"] + flags @?= emptyFlags + { applicationDirs = Flag ["app"] + } + , testCase "Multiple applicationDirs" $ do + flags <- runParserTest ["--application-dir", "app", + "--application-dir", "exe", + "--application-dir", "srcapp"] + flags @?= emptyFlags + { applicationDirs = Flag ["app", "exe", "srcapp"] + } + , testCase "Single sourceDirs" $ do + flags <- runParserTest ["--source-dir", "src"] + flags @?= emptyFlags + { sourceDirs = Flag ["src"] + } + , testCase "Multiple sourceDirs" $ do + flags <- runParserTest ["--source-dir", "src", + "--source-dir", "lib", + "--source-dir", "sources"] + flags @?= emptyFlags + { sourceDirs = Flag ["src", "lib", "sources"] + } + , testCase "Single buildTools" $ do + flags <- runParserTest ["--build-tool", "happy"] + flags @?= emptyFlags + { buildTools = Flag ["happy"] + } + , testCase "Multiple buildTools" $ do + flags <- runParserTest ["--build-tool", "happy", + "--build-tool", "alex", + "--build-tool", "make"] + flags @?= emptyFlags + { buildTools = Flag ["happy", "alex", "make"] + } + , testCase "Single testDirs" $ do + flags <- runParserTest ["--test-dir", "test"] + flags @?= emptyFlags + { testDirs = Flag ["test"] + } + , testCase "Multiple testDirs" $ do + flags <- runParserTest ["--test-dir", "test", + "--test-dir", "tests", + "--test-dir", "testsuite"] + flags @?= emptyFlags + { testDirs = Flag ["test", "tests", "testsuite"] + } + ] + where + assumeAllParse :: CommandParse (InitFlags -> InitFlags, [String]) -> IO InitFlags + assumeAllParse = \case + CommandReadyToGo (flagsF, []) -> pure (flagsF emptyFlags) + _ -> assertFailure "Expected successful parse" + + runParserTest :: [String] -> IO InitFlags + runParserTest opts = do + assumeAllParse $ commandParseArgs initCommand False opts diff --git a/tests/UnitTests/Distribution/Client/Init/Simple.hs b/tests/UnitTests/Distribution/Client/Init/Simple.hs --- a/tests/UnitTests/Distribution/Client/Init/Simple.hs +++ b/tests/UnitTests/Distribution/Client/Init/Simple.hs @@ -50,7 +50,12 @@ [ testCase "Simple lib createProject - no tests" $ do let inputs = fromList [ "1" -- package type: Library - , "simple-test" -- package dir (ignored, piped to current dir due to prompt monad) + , "simple.test" -- package dir: used for determining package name; + -- note that . will be replaced with - in a sanitization step, + -- and we get the expected "simple-test" -- regression test for #8404 + , "simple.test" -- package dir again: the prompt monad needs extra parameter for every + -- IO call, and this one will be used for canonicalizePath, + -- which is called as a part of sanitization , "n" -- no tests ] @@ -65,7 +70,7 @@ Right (settings', _) -> settings @=? settings' , testCase "Simple lib createProject - with tests" $ do - let inputs = fromList ["1", "simple-test", "y", "1"] + let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"] flags = emptyFlags { packageType = Flag Library } settings = ProjectSettings (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion) @@ -77,7 +82,7 @@ Right (settings', _) -> settings @=? settings' , testCase "Simple exe createProject" $ do - let inputs = fromList ["2", "simple-test"] + let inputs = fromList ["2", "simple-test", "simple-test"] flags = emptyFlags { packageType = Flag Executable } settings = ProjectSettings (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion) @@ -89,7 +94,7 @@ Right (settings', _) -> settings @=? settings' , testCase "Simple lib+exe createProject - no tests" $ do - let inputs = fromList ["2", "simple-test", "n"] + let inputs = fromList ["2", "simple-test", "simple-test", "n"] flags = emptyFlags { packageType = Flag LibraryAndExecutable } settings = ProjectSettings (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) @@ -100,7 +105,7 @@ Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e Right (settings', _) -> settings @=? settings' , testCase "Simple lib+exe createProject - with tests" $ do - let inputs = fromList ["2", "simple-test", "y", "1"] + let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] flags = emptyFlags { packageType = Flag LibraryAndExecutable } settings = ProjectSettings (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion) @@ -113,7 +118,7 @@ Right (settings', _) -> settings @=? settings' , testCase "Simple standalone tests" $ do - let inputs = fromList ["2", "simple-test", "y", "1"] + let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"] flags = emptyFlags { packageType = Flag TestSuite } settings = ProjectSettings (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion) diff --git a/tests/UnitTests/Distribution/Client/Init/Utils.hs b/tests/UnitTests/Distribution/Client/Init/Utils.hs --- a/tests/UnitTests/Distribution/Client/Init/Utils.hs +++ b/tests/UnitTests/Distribution/Client/Init/Utils.hs @@ -51,7 +51,7 @@ emptyFlags :: InitFlags emptyFlags = mempty --- | Retireves the proper base version based on the GHC version +-- | Retrieves the proper base version based on the GHC version baseVersion :: Compiler -> VersionRange baseVersion Compiler {compilerId = CompilerId GHC ver} = let ghcToBase = baseVersion' . prettyShow $ ver in @@ -67,7 +67,6 @@ baseVersion' "8.6.5" = [4,12,0,0] baseVersion' "8.4.4" = [4,11,1,0] baseVersion' "8.2.2" = [4,10,1,0] -baseVersion' "8.0.2" = [4,10,0,0] baseVersion' "7.10.3" = [4,9,0,0] baseVersion' "7.8.4" = [4,8,0,0] baseVersion' "7.6.3" = [4,7,0,0] diff --git a/tests/UnitTests/Distribution/Client/InstallPlan.hs b/tests/UnitTests/Distribution/Client/InstallPlan.hs --- a/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ b/tests/UnitTests/Distribution/Client/InstallPlan.hs @@ -124,7 +124,7 @@ (Just ixu, Just ixv) -> ixu > ixv _ -> True | let ixs = array (bounds g) - (zip (range (bounds g)) (repeat Nothing) ++ + (zip (range (bounds g)) (repeat Nothing) ++ zip vs (map Just [0::Int ..])) , (u,v) <- edges g ] diff --git a/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/tests/UnitTests/Distribution/Client/ProjectConfig.hs --- a/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -29,6 +29,7 @@ import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db import Distribution.Simple.Utils (toUTF8BS) +import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Types.PackageVersionConstraint import Distribution.Parsec @@ -456,6 +457,7 @@ projectConfigHcPath <- arbitraryFlag arbitraryShortToken projectConfigHcPkg <- arbitraryFlag arbitraryShortToken projectConfigHaddockIndex <- arbitrary + projectConfigInstallDirs <- fixInstallDirs <$> arbitrary projectConfigPackageDBs <- shortListOf 2 arbitrary projectConfigRemoteRepos <- arbitrary projectConfigLocalNoIndexRepos <- arbitrary @@ -479,12 +481,14 @@ projectConfigOnlyConstrained <- arbitrary projectConfigPerComponent <- arbitrary projectConfigIndependentGoals <- arbitrary + projectConfigPreferOldest <- arbitrary projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken return ProjectConfigShared {..} where arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] arbitraryConstraints = fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary + fixInstallDirs x = x {InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty} shrink ProjectConfigShared {..} = runShrinker $ pure ProjectConfigShared <*> shrinker projectConfigDistDir @@ -495,6 +499,7 @@ <*> shrinkerAla (fmap NonEmpty) projectConfigHcPath <*> shrinkerAla (fmap NonEmpty) projectConfigHcPkg <*> shrinker projectConfigHaddockIndex + <*> shrinker projectConfigInstallDirs <*> shrinker projectConfigPackageDBs <*> shrinker projectConfigRemoteRepos <*> shrinker projectConfigLocalNoIndexRepos @@ -518,6 +523,7 @@ <*> shrinker projectConfigOnlyConstrained <*> shrinker projectConfigPerComponent <*> shrinker projectConfigIndependentGoals + <*> shrinker projectConfigPreferOldest <*> shrinker projectConfigProgPathExtra where preShrink_Constraints = map fst @@ -571,10 +577,13 @@ <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> arbitrary + <*> arbitraryFlag arbitraryShortToken + <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitraryFlag arbitraryShortToken <*> arbitrary <*> shortListOf 5 arbitrary @@ -634,6 +643,9 @@ , packageConfigHaddockHscolourCss = x39 , packageConfigHaddockContents = x40 , packageConfigHaddockForHackage = x41 + , packageConfigHaddockIndex = x54 + , packageConfigHaddockBaseUrl = x55 + , packageConfigHaddockLib = x56 , packageConfigTestHumanLog = x44 , packageConfigTestMachineLog = x45 , packageConfigTestShowDetails = x46 @@ -691,6 +703,9 @@ , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' , packageConfigHaddockContents = x40' , packageConfigHaddockForHackage = x41' + , packageConfigHaddockIndex = x54' + , packageConfigHaddockBaseUrl = x55' + , packageConfigHaddockLib = x56' , packageConfigTestHumanLog = x44' , packageConfigTestMachineLog = x45' , packageConfigTestShowDetails = x46' @@ -708,7 +723,8 @@ (x30', x31', x32', (x33', x33_1'), x34'), (x35', x36', x37', x38', x43', x39'), (x40', x41'), - (x44', x45', x46', x47', x48', x49', x51', x52'))) + (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55'), + x56')) <- shrink (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), (x05, x42, x06, x50, x07, x08, x09), @@ -722,7 +738,7 @@ (x30, x31, x32, (x33, x33_1), x34), (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39), (x40, x41), - (x44, x45, x46, x47, x48, x49, x51, x52))) + (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55), x56)) ] where preShrink_Paths = Map.map NonEmpty @@ -794,6 +810,9 @@ instance Arbitrary IndependentGoals where arbitrary = IndependentGoals <$> arbitrary + +instance Arbitrary PreferOldest where + arbitrary = PreferOldest <$> arbitrary instance Arbitrary StrongFlags where arbitrary = StrongFlags <$> arbitrary diff --git a/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs --- a/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -54,6 +54,7 @@ instance ToExpr PackageConfig instance ToExpr PackageDB instance ToExpr PackageProperty +instance ToExpr PreferOldest instance ToExpr PreSolver instance ToExpr ProjectConfig instance ToExpr ProjectConfigBuildOnly diff --git a/tests/UnitTests/Distribution/Client/VCS.hs b/tests/UnitTests/Distribution/Client/VCS.hs --- a/tests/UnitTests/Distribution/Client/VCS.hs +++ b/tests/UnitTests/Distribution/Client/VCS.hs @@ -301,7 +301,7 @@ -- -- So, given a source repo dir, the corresponding 'RepoState' and a number of -- target repo dirs, pick a sequence of (lists of) sync targets from the --- 'RepoState' and syncronise the target dirs with those targets, checking for +-- 'RepoState' and synchronise the target dirs with those targets, checking for -- each one that the actual working state matches the expected repo state. -- checkSyncRepos diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs --- a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -474,12 +474,14 @@ } } pkgCheckErrors = - -- We ignore these warnings because some unit tests test that the - -- solver allows unknown extensions/languages when the compiler - -- supports them. - let ignore = ["Unknown extensions:", "Unknown languages:"] - in [ err | err <- C.checkPackage (srcpkgDescription package) Nothing - , not $ any (`isPrefixOf` C.explanation err) ignore ] + -- We ignore unknown extensions/languages warnings because + -- some there are some unit tests test in which the solver allows + -- unknown extensions/languages when the compiler supports them. + -- Furthermore we ignore missing upper bound warnings because + -- they are not related to this test suite, and are tested + -- with golden tests. + let checks = C.checkPackage (srcpkgDescription package) Nothing + in filter (\x -> not (isMissingUpperBound x) && not (isUnknownLangExt x)) checks in if null pkgCheckErrors then package else error $ "invalid GenericPackageDescription for package " @@ -666,6 +668,18 @@ (directDeps, []) -> map mkDirect directDeps _ -> error "mkSetupDeps: custom setup has non-simple deps" + -- Check for `UnknownLanguages` and `UnknownExtensions`. See + isUnknownLangExt :: C.PackageCheck -> Bool + isUnknownLangExt pc = case C.explanation pc of + C.UnknownExtensions {} -> True + C.UnknownLanguages {} -> True + _ -> False + isMissingUpperBound :: C.PackageCheck -> Bool + isMissingUpperBound pc = case C.explanation pc of + C.MissingUpperBounds {} -> True + _ -> False + + mkSimpleVersion :: ExamplePkgVersion -> C.Version mkSimpleVersion n = C.mkVersion [n, 0, 0] @@ -733,6 +747,7 @@ -> FineGrainedConflicts -> MinimizeConflictSet -> IndependentGoals + -> PreferOldest -> ReorderGoals -> AllowBootLibInstalls -> OnlyConstrained @@ -745,7 +760,7 @@ -> EnableAllTests -> Progress String String CI.SolverInstallPlan.SolverInstallPlan exResolve db exts langs pkgConfigDb targets mbj countConflicts - fineGrainedConflicts minimizeConflictSet indepGoals reorder + fineGrainedConflicts minimizeConflictSet indepGoals prefOldest reorder allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder constraints prefs verbosity enableAllTests = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params @@ -774,6 +789,7 @@ $ setFineGrainedConflicts fineGrainedConflicts $ setMinimizeConflictSet minimizeConflictSet $ setIndependentGoals indepGoals + $ (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $ setReorderGoals reorder $ setMaxBackjumps mbj $ setAllowBootLibInstalls allowBootLibInstalls diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs --- a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs @@ -7,6 +7,7 @@ , disableFineGrainedConflicts , minimizeConflictSet , independentGoals + , preferOldest , allowBootLibInstalls , onlyConstrained , disableBackjumping @@ -66,6 +67,10 @@ independentGoals :: SolverTest -> SolverTest independentGoals test = test { testIndepGoals = IndependentGoals True } +-- | Combinator to turn on --prefer-oldest +preferOldest :: SolverTest -> SolverTest +preferOldest test = test { testPreferOldest = PreferOldest True } + allowBootLibInstalls :: SolverTest -> SolverTest allowBootLibInstalls test = test { testAllowBootLibInstalls = AllowBootLibInstalls True } @@ -111,6 +116,7 @@ , testFineGrainedConflicts :: FineGrainedConflicts , testMinimizeConflictSet :: MinimizeConflictSet , testIndepGoals :: IndependentGoals + , testPreferOldest :: PreferOldest , testAllowBootLibInstalls :: AllowBootLibInstalls , testOnlyConstrained :: OnlyConstrained , testEnableBackjumping :: EnableBackjumping @@ -208,6 +214,7 @@ , testFineGrainedConflicts = FineGrainedConflicts True , testMinimizeConflictSet = MinimizeConflictSet False , testIndepGoals = IndependentGoals False + , testPreferOldest = PreferOldest False , testAllowBootLibInstalls = AllowBootLibInstalls False , testOnlyConstrained = OnlyConstrainedNone , testEnableBackjumping = EnableBackjumping True @@ -230,7 +237,7 @@ testSupportedLangs testPkgConfigDb testTargets testMaxBackjumps (CountConflicts True) testFineGrainedConflicts testMinimizeConflictSet - testIndepGoals (ReorderGoals False) testAllowBootLibInstalls + testIndepGoals testPreferOldest (ReorderGoals False) testAllowBootLibInstalls testOnlyConstrained testEnableBackjumping testSolveExecutables (sortGoals <$> testGoalOrder) testConstraints testSoftConstraints testVerbosity testEnableAllTests diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs --- a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -57,7 +57,7 @@ r2 = solve' mGoalOrder2 test { testTargets = targets2 } solve' goalOrder = solve (EnableBackjumping True) (FineGrainedConflicts True) - (ReorderGoals False) (CountConflicts True) indepGoals + (ReorderGoals False) (CountConflicts True) indepGoals (PreferOldest False) (getBlind <$> goalOrder) targets = testTargets test targets2 = case targetOrder of @@ -74,7 +74,7 @@ r2 = solve' (IndependentGoals True) test solve' indep = solve (EnableBackjumping True) (FineGrainedConflicts True) - reorderGoals (CountConflicts True) indep Nothing + reorderGoals (CountConflicts True) indep (PreferOldest False)Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) `implies` isRight (resultPlan r2) @@ -85,7 +85,7 @@ r2 = solve' (EnableBackjumping False) test solve' enableBj = solve enableBj (FineGrainedConflicts False) reorderGoals - (CountConflicts True) indepGoals Nothing + (CountConflicts True) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) @@ -96,11 +96,22 @@ r2 = solve' (FineGrainedConflicts False) test solve' fineGrainedConflicts = solve (EnableBackjumping True) fineGrainedConflicts - reorderGoals (CountConflicts True) indepGoals Nothing + reorderGoals (CountConflicts True) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> isRight (resultPlan r1) === isRight (resultPlan r2) + , testPropertyWithSeed "prefer oldest does not affect solvability" $ + \test reorderGoals indepGoals -> + let r1 = solve' (PreferOldest True) test + r2 = solve' (PreferOldest False) test + solve' prefOldest = + solve (EnableBackjumping True) (FineGrainedConflicts True) + reorderGoals (CountConflicts True) indepGoals prefOldest Nothing + in counterexample (showResults r1 r2) $ + noneReachedBackjumpLimit [r1, r2] ==> + isRight (resultPlan r1) === isRight (resultPlan r2) + -- The next two tests use --no-count-conflicts, because the goal order used -- with --count-conflicts depends on the total set of conflicts seen by the -- solver. The solver explores more of the tree and encounters more @@ -116,7 +127,7 @@ r2 = solve' (EnableBackjumping False) test solve' enableBj = solve enableBj (FineGrainedConflicts False) reorderGoals - (CountConflicts False) indepGoals Nothing + (CountConflicts False) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 @@ -128,7 +139,7 @@ r2 = solve' (FineGrainedConflicts False) test solve' fineGrainedConflicts = solve (EnableBackjumping True) fineGrainedConflicts - reorderGoals (CountConflicts False) indepGoals Nothing + reorderGoals (CountConflicts False) indepGoals (PreferOldest False) Nothing in counterexample (showResults r1 r2) $ noneReachedBackjumpLimit [r1, r2] ==> resultPlan r1 === resultPlan r2 @@ -163,10 +174,11 @@ -> ReorderGoals -> CountConflicts -> IndependentGoals + -> PreferOldest -> Maybe VarOrdering -> SolverTest -> Result -solve enableBj fineGrainedConflicts reorder countConflicts indep goalOrder test = +solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goalOrder test = let (lg, result) = runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing (pkgConfigDbFromList []) @@ -175,7 +187,7 @@ -- too much time and memory. (Just defaultMaxBackjumps) countConflicts fineGrainedConflicts - (MinimizeConflictSet False) indep reorder + (MinimizeConflictSet False) indep prefOldest reorder (AllowBootLibInstalls False) OnlyConstrainedNone enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder) (testConstraints test) (testPreferences test) normal diff --git a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs --- a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs @@ -30,6 +30,8 @@ testGroup "Simple dependencies" [ runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess []) , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)]) + , runTest $ preferOldest + $ mkTest db1 "installOldest" ["B"] (solverSuccess [("B", 1)]) , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure @@ -146,11 +148,17 @@ , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)]) ] - , testGroup "Base" [ + , testGroup "Base and Nonupgradable" [ runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $ solverFailure (isInfixOf "only already installed instances can be used") , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] + , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $ + solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-upgradeable package requires installed instance)") + , runTest $ mkTest dbNonupgrade "Refuse to install newer ghci requested by another library" ["B"] $ + solverFailure (isInfixOf "rejecting: ghci-2.0.0 (constraint from non-upgradeable package requires installed instance)") + , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc-boot requested by another library" ["C"] $ + solverFailure (isInfixOf "rejecting: ghc-boot-2.0.0 (constraint from non-upgradeable package requires installed instance)") ] , testGroup "reject-unconstrained" [ runTest $ onlyConstrained $ mkTest db12 "missing syb" ["E"] $ @@ -1120,6 +1128,19 @@ , Right $ exAv "integer-simple" 1 [] , Right $ exAv "integer-gmp" 1 [] ] + +dbNonupgrade :: ExampleDb +dbNonupgrade = [ + Left $ exInst "ghc" 1 "ghc-1" [] + , Left $ exInst "ghci" 1 "ghci-1" [] + , Left $ exInst "ghc-boot" 1 "ghc-boot-1" [] + , Right $ exAv "ghc" 2 [] + , Right $ exAv "ghci" 2 [] + , Right $ exAv "ghc-boot" 2 [] + , Right $ exAv "A" 1 [ExFix "ghc" 2] + , Right $ exAv "B" 1 [ExFix "ghci" 2] + , Right $ exAv "C" 1 [ExFix "ghc-boot" 2] + ] db13 :: ExampleDb db13 = [