diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Change-log +## 3.16.1.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) December 2025 + +* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.16.1.0.md + ## 3.16.0.0 [Artem Pelenitsyn](mailto:a@pelenitsyn.top) July 2025 * See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.16.0.0.md diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,7 +1,7 @@ Cabal-Version: 3.6 Name: cabal-install -Version: 3.16.0.0 +Version: 3.16.1.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -62,15 +62,15 @@ common cabal-dep build-depends: - , Cabal ^>=3.16 + , Cabal ^>=3.16.1.0 common cabal-syntax-dep build-depends: - , Cabal-syntax ^>=3.16 + , Cabal-syntax ^>=3.16.1.0 common cabal-install-solver-dep build-depends: - , cabal-install-solver ^>=3.16 + , cabal-install-solver ^>=3.16.1.0 library import: warnings, base-dep, cabal-dep, cabal-syntax-dep, cabal-install-solver-dep @@ -245,13 +245,13 @@ , filepath >= 1.4.0.0 && < 1.6 , HTTP >= 4000.1.5 && < 4000.5 , mtl >= 2.0 && < 2.4 - , network-uri >= 2.6.0.2 && < 2.7 + , network-uri >= 2.6.2.0 && < 2.7 , pretty >= 1.1 && < 1.2 , process >= 1.2.3.0 && < 1.7 , random >= 1.2 && < 1.4 , stm >= 2.0 && < 2.6 - , tar >= 0.5.0.3 && < 0.7 - , time >= 1.5.0.1 && < 1.15 + , tar >= 0.5.0.3 && < 0.8 + , time >= 1.5.0.1 && < 1.16 , zlib >= 0.5.3 && < 0.8 , hackage-security >= 0.6.2.0 && < 0.7 , text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2 @@ -376,7 +376,7 @@ , tasty-expected-failure , tasty-hunit >= 0.10 , tree-diff - , QuickCheck >= 2.14.3 && <2.17 + , QuickCheck >= 2.14.3 && <2.18 -- Tests to run with a limited stack and heap size -- The test suite name must be keep short cause a longer one @@ -465,5 +465,5 @@ , tasty-expected-failure , tasty-hunit >= 0.10 , tasty-quickcheck <0.12 - , QuickCheck >= 2.14 && <2.17 + , QuickCheck >= 2.14 && <2.18 , pretty-show >= 1.6.15 diff --git a/src/Distribution/Client/CmdPath.hs b/src/Distribution/Client/CmdPath.hs --- a/src/Distribution/Client/CmdPath.hs +++ b/src/Distribution/Client/CmdPath.hs @@ -25,7 +25,7 @@ , defaultStoreDir , getConfigFilePath ) -import Distribution.Client.DistDirLayout (CabalDirLayout (..), distProjectRootDirectory) +import Distribution.Client.DistDirLayout (CabalDirLayout (..), StoreDirLayout (..), distProjectRootDirectory) import Distribution.Client.Errors import Distribution.Client.GlobalFlags import Distribution.Client.NixStyleOptions @@ -244,11 +244,18 @@ if not $ fromFlagOrDefault False (pathCompiler pathFlags) then pure Nothing else do - (compiler, _, progDb) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) + (compiler, _, progDb) <- + runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $ + configureCompiler verbosity (distDirLayout baseCtx) (projectConfig baseCtx) compilerProg <- requireCompilerProg verbosity compiler (configuredCompilerProg, _) <- requireProgram verbosity compilerProg progDb - pure $ Just $ mkCompilerInfo configuredCompilerProg compiler + let compilerInfo' = + mkCompilerInfo configuredCompilerProg compiler $ + cabalStoreDirLayout (cabalDirLayout baseCtx) + + pure $ Just compilerInfo' + paths <- for (fromFlagOrDefault [] $ pathDirectories pathFlags) $ \p -> do t <- getPathLocation baseCtx p pure (pathName p, t) @@ -317,16 +324,20 @@ data PathCompilerInfo = PathCompilerInfo { pathCompilerInfoFlavour :: CompilerFlavor , pathCompilerInfoId :: CompilerId + , pathCompilerInfoAbiTag :: String , pathCompilerInfoPath :: FilePath + , pathCompilerInfoStorePath :: FilePath } deriving (Show, Eq, Ord) -mkCompilerInfo :: ConfiguredProgram -> Compiler -> PathCompilerInfo -mkCompilerInfo compilerProgram compiler = +mkCompilerInfo :: ConfiguredProgram -> Compiler -> StoreDirLayout -> PathCompilerInfo +mkCompilerInfo compilerProgram compiler storeLayout = PathCompilerInfo { pathCompilerInfoFlavour = compilerFlavor compiler , pathCompilerInfoId = compilerId compiler + , pathCompilerInfoAbiTag = showCompilerIdWithAbi compiler , pathCompilerInfoPath = programPath compilerProgram + , pathCompilerInfoStorePath = storeDirectory storeLayout compiler } -- ---------------------------------------------------------------------------- @@ -371,7 +382,9 @@ .= Json.object [ "flavour" .= jdisplay (pathCompilerInfoFlavour pci) , "id" .= jdisplay (pathCompilerInfoId pci) + , "abi-tag" .= Json.String (pathCompilerInfoAbiTag pci) , "path" .= Json.String (pathCompilerInfoPath pci) + , "store-path" .= Json.String (pathCompilerInfoStorePath pci) ] ] @@ -400,5 +413,7 @@ compilerInfoToKeyValue pci = [ ("compiler-flavour", prettyShow $ pathCompilerInfoFlavour pci) , ("compiler-id", prettyShow $ pathCompilerInfoId pci) + , ("compiler-abi-tag", pathCompilerInfoAbiTag pci) , ("compiler-path", pathCompilerInfoPath pci) + , ("compiler-store-path", pathCompilerInfoStorePath pci) ] 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 @@ -106,7 +106,8 @@ ) import Distribution.Simple.Program.GHC import Distribution.Simple.Setup - ( ReplOptions (..) + ( Flag + , ReplOptions (..) , commonSetupTempFileOptions ) import Distribution.Simple.Utils @@ -170,8 +171,8 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Distribution.Client.ProjectConfig - ( ProjectConfig (projectConfigShared) - , ProjectConfigShared (projectConfigConstraints, projectConfigMultiRepl) + ( ProjectConfig (..) + , ProjectConfigShared (..) ) import Distribution.Client.ReplFlags ( EnvFlags (envIncludeTransitive, envPackages) @@ -184,6 +185,7 @@ import Distribution.Simple.Program.Builtin (ghcProgram) import Distribution.Simple.Program.Db (requireProgram) import Distribution.Simple.Program.Types +import Distribution.Types.PackageName.Magic (fakePackageId) import System.Directory ( doesFileExist , getCurrentDirectory @@ -195,6 +197,7 @@ , splitSearchPath , () ) +import Text.PrettyPrint hiding ((<>)) replCommand :: CommandUI (NixStyleFlags ReplFlags) replCommand = @@ -281,17 +284,30 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO () -replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags = - withContextAndSelectors verbosity AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do +replAction flags@NixStyleFlags{extraFlags = replFlags@ReplFlags{..}, configFlags} targetStrings globalFlags = do + withCtx verbosity targetStrings $ \targetCtx ctx userTargetSelectors -> do when (buildSettingOnlyDeps (buildSettings ctx)) $ dieWithException verbosity ReplCommandDoesn'tSupport let projectRoot = distProjectRootDirectory $ distDirLayout ctx distDir = distDirectory $ distDirLayout ctx - baseCtx <- case targetCtx of - ProjectContext -> return ctx + -- After ther user selectors have been resolved, and it's decided what context + -- we're in, implement repl-specific behaviour. + (baseCtx, targetSelectors) <- case targetCtx of + -- If in the project context, and no selectors are provided + -- then produce an error. + ProjectContext -> do + let projectFile = projectConfigProjectFile . projectConfigShared $ projectConfig ctx + let pkgs = projectPackages $ projectConfig ctx + case userTargetSelectors of + [] -> + dieWithException verbosity $ + RenderReplTargetProblem [render (reportProjectNoTarget projectFile pkgs)] + _ -> return (ctx, userTargetSelectors) + -- In the global context, construct a fake package which can be used to start + -- a repl with extra arguments if `-b` is given. GlobalContext -> do - unless (null targetStrings) $ + unless (null userTargetSelectors) $ dieWithException verbosity $ ReplTakesNoArguments targetStrings let @@ -302,12 +318,18 @@ library = emptyLibrary{libBuildInfo = lBuildInfo} lBuildInfo = emptyBuildInfo - { targetBuildDepends = [baseDep] + { targetBuildDepends = [baseDep] ++ envPackages replEnvFlags , defaultLanguage = Just Haskell2010 } baseDep = Dependency "base" anyVersion mainLibSet - updateContextAndWriteProjectFile' ctx sourcePackage + -- Write the fake package + updatedCtx <- updateContextAndWriteProjectFile' ctx sourcePackage + -- Specify the selector for this package + let fakeSelector = TargetPackage TargetExplicitNamed [fakePackageId] Nothing + return (updatedCtx, [fakeSelector]) + + -- For the script context, no special behaviour. ScriptContext scriptPath scriptExecutable -> do unless (length targetStrings == 1) $ dieWithException verbosity $ @@ -317,7 +339,8 @@ dieWithException verbosity $ ReplTakesSingleArgument targetStrings - updateContextAndWriteProjectFile ctx scriptPath scriptExecutable + updatedCtx <- updateContextAndWriteProjectFile ctx scriptPath scriptExecutable + return (updatedCtx, userTargetSelectors) -- If multi-repl is used, we need a Cabal recent enough to handle it. -- We need to do this before solving, but the compiler version is only known @@ -360,7 +383,7 @@ -- especially in the no-project case. withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + targets <- validatedTargets' (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors let (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets @@ -384,7 +407,7 @@ let ProjectBaseContext{..} = baseCtx'' -- Recalculate with updated project. - targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors + targets <- validatedTargets' (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors let elaboratedPlan' = @@ -481,7 +504,8 @@ unit_files_ordered :: [FilePath] unit_files_ordered = let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files - in -- GHC considers the last unit passed to be the active one + in -- older GHC versions consider the last unit passed to be the active one. + -- GHC 9.14 no longer has the notion of "active" units. other_units ++ active_unit_files convertParStrat :: ParStratX Int -> ParStratX String @@ -517,31 +541,13 @@ go m ("PATH", Just s) = foldl' (\m' f -> Map.insertWith (+) f 1 m') m (splitSearchPath s) go m _ = m + withCtx ctxVerbosity strings = + withContextAndSelectors ctxVerbosity AcceptNoTargets (Just LibKind) flags strings globalFlags ReplCommand + verbosity = cfgVerbosity normal flags tempFileOptions = commonSetupTempFileOptions $ configCommonFlags configFlags - validatedTargets ctx compiler elaboratedPlan targetSelectors = do - let multi_repl_enabled = multiReplDecision ctx compiler r - -- Interpret the targets on the command line as repl targets - -- (as opposed to say build or haddock targets). - targets <- - either (reportTargetProblems verbosity) return $ - resolveTargetsFromSolver - (selectPackageTargets multi_repl_enabled) - selectComponentTarget - elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $ - reportTargetProblems - verbosity - [multipleTargetsProblem multi_repl_enabled targets] - - return targets + validatedTargets' = validatedTargets verbosity replFlags -- | Create a constraint which requires a later version of Cabal. -- This is used for commands which require a specific feature from the Cabal library @@ -553,6 +559,69 @@ (PackagePropertyVersion $ orLaterVersion $ mkVersion version) , source ) + +reportProjectNoTarget :: Flag FilePath -> [String] -> Doc +reportProjectNoTarget projectFile pkgs = + case (null pkgs, projectName) of + (True, Just project) -> + text "There are no packages in" + <+> (project <> char '.') + <+> text "Please add a package to the project and" + <+> pickComponent + (True, Nothing) -> + text "Please add a package to the project and" <+> pickComponent + (False, Just project) -> + text "Please" + <+> pickComponent + <+> text "The packages in" + <+> project + <+> (text "from which to select a component target are" <> colon) + $+$ nest 1 (vcat [text "-" <+> text pkg | pkg <- sort pkgs]) + (False, Nothing) -> + text "Please" + <+> pickComponent + <+> (text "The packages from which to select a component in 'cabal.project'" <> comma) + <+> (text "the implicit default as if `--project-file=cabal.project` was added as a command option" <> comma) + <+> (text "are" <> colon) + $+$ nest 1 (vcat [text "-" <+> text pkg | pkg <- sort pkgs]) + where + projectName = case projectFile of + Flag "" -> Nothing + Flag n -> Just $ quotes (text n) + _ -> Nothing + pickComponent = text "pick a single [package:][ctype:]component (or all) as target for the REPL command." + +-- | Invariant: validatedTargets returns at least one target for the REPL. +validatedTargets + :: Verbosity + -> ReplFlags + -> ProjectConfigShared + -> Compiler + -> ElaboratedInstallPlan + -> [TargetSelector] + -> IO TargetsMap +validatedTargets verbosity replFlags ctx compiler elaboratedPlan targetSelectors = do + let multi_repl_enabled = multiReplDecision ctx compiler replFlags + -- Interpret the targets on the command line as repl targets (as opposed to + -- say build or haddock targets). + targets <- + either (reportTargetProblems verbosity) return $ + resolveTargetsFromSolver + (selectPackageTargets multi_repl_enabled) + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different components. It is + -- ok to have two module/file targets in the same component, but not two that + -- live in different components. + when (Set.size (distinctTargetComponents targets) > 1 && not (useMultiRepl multi_repl_enabled)) $ + reportTargetProblems + verbosity + [multipleTargetsProblem multi_repl_enabled targets] + + return targets -- | First version of GHC which supports multiple home packages minMultipleHomeUnitsVersion :: Version diff --git a/src/Distribution/Client/Compat/Tar.hs b/src/Distribution/Client/Compat/Tar.hs --- a/src/Distribution/Client/Compat/Tar.hs +++ b/src/Distribution/Client/Compat/Tar.hs @@ -4,6 +4,7 @@ {- FOURMOLU_DISABLE -} module Distribution.Client.Compat.Tar ( extractTarGzFile + , createTarGzFile #if MIN_VERSION_tar(0,6,0) , Tar.Entry , Tar.Entries @@ -27,6 +28,7 @@ #else import qualified Codec.Archive.Tar.Entry as Tar #endif +import qualified Codec.Compression.GZip as GZip import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.GZipUtils as GZipUtils @@ -65,4 +67,20 @@ . Tar.read . GZipUtils.maybeDecompress =<< BS.readFile tar + +createTarGzFile + :: FilePath + -- ^ Full Tarball path + -> FilePath + -- ^ Base directory + -> FilePath + -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar base dir = +#if MIN_VERSION_tar(0,7,0) + BS.writeFile tar . GZip.compress =<< Tar.write' =<< Tar.pack' base [dir] +#else + BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] +#endif + {- FOURMOLU_ENABLE -} diff --git a/src/Distribution/Client/Main.hs b/src/Distribution/Client/Main.hs --- a/src/Distribution/Client/Main.hs +++ b/src/Distribution/Client/Main.hs @@ -373,17 +373,20 @@ -> [String] -> IO (CommandParse Action) delegateToExternal commands' name cmdArgs = do + -- we rely on cabal's implementation of findProgramOnSearchPath not following + -- symlinks here. If that ever happens, then the argv[0] of the called executable + -- will be different from the intended one and will break tools that work by reading it. mCommand <- findProgramOnSearchPath normal defaultProgramSearchPath ("cabal-" <> name) case mCommand of - Just (exec, _) -> return (CommandReadyToGo $ \_ -> callExternal exec name cmdArgs) + Just (exec, _) -> return (CommandReadyToGo $ \_ -> callExternal exec cmdArgs) Nothing -> defaultCommandFallback commands' name cmdArgs - callExternal :: String -> String -> [String] -> IO () - callExternal exec name cmdArgs = do + callExternal :: String -> [String] -> IO () + callExternal exec cmdArgs = do cur_env <- getEnvironment cabal_exe <- getExecutablePath - let new_env = ("CABAL", cabal_exe) : cur_env - result <- try $ createProcess ((proc exec (name : cmdArgs)){env = Just new_env}) + let new_env = ("CABAL_EXTERNAL_CABAL_PATH", cabal_exe) : cur_env + result <- try $ createProcess ((proc exec cmdArgs){env = Just new_env}) case result of Left ex -> printErrors ["Error executing external command: " ++ show (ex :: SomeException)] Right (_, _, _, ph) -> waitForProcess ph >>= exitWith diff --git a/src/Distribution/Client/Tar.hs b/src/Distribution/Client/Tar.hs --- a/src/Distribution/Client/Tar.hs +++ b/src/Distribution/Client/Tar.hs @@ -17,7 +17,7 @@ -- Reading, writing and manipulating \"@.tar@\" archive files. module Distribution.Client.Tar ( -- * @tar.gz@ operations - createTarGzFile + TarComp.createTarGzFile , TarComp.extractTarGzFile -- * Other local utils @@ -34,8 +34,6 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar -import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString.Lazy as BS import qualified Distribution.Client.Compat.Tar as TarComp -- for foldEntries... @@ -44,19 +42,6 @@ -- -- * High level operations - --- - -createTarGzFile - :: FilePath - -- ^ Full Tarball path - -> FilePath - -- ^ Base directory - -> FilePath - -- ^ Directory to archive, relative to base dir - -> IO () -createTarGzFile tar base dir = - BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir] -- | Type code for the local build tree reference entry type. We don't use the -- symbolic link entry type because it allows only 100 ASCII characters for the