diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs index 88afef0af91..c5839b6e0d0 100644 --- a/Cabal/src/Distribution/Simple/Program/Run.hs +++ b/Cabal/src/Distribution/Simple/Program/Run.hs @@ -61,6 +61,7 @@ data ProgramInvocation = ProgramInvocation , progInvokeInputEncoding :: IOEncoding -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. , progInvokeOutputEncoding :: IOEncoding + , progInvokeWhen :: IO Bool } data IOEncoding @@ -82,6 +83,7 @@ emptyProgramInvocation = , progInvokeInput = Nothing , progInvokeInputEncoding = IOEncodingText , progInvokeOutputEncoding = IOEncodingText + , progInvokeWhen = pure True } simpleProgramInvocation diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index f19ca5ff566..98b8251d9c1 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -96,6 +96,7 @@ import qualified Data.List as List import qualified Data.Map as Map import System.Directory ( doesDirectoryExist + , doesFileExist , removeDirectoryRecursive , removePathForcibly ) @@ -468,11 +469,18 @@ vcsGit = [programInvocation prog cloneArgs] -- And if there's a tag, we have to do that in a second step: ++ [git (resetArgs tag) | tag <- maybeToList (srpTag repo)] - ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg) - , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg) + ++ [ whenGitModulesExists $ git $ ["submodule", "sync", "--recursive"] ++ verboseArg + , whenGitModulesExists $ git $ ["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg ] where git args = (programInvocation prog args){progInvokeCwd = Just destdir} + + gitModulesPath = destdir ".gitmodules" + whenGitModulesExists invocation = + invocation + { progInvokeWhen = doesFileExist gitModulesPath + } + cloneArgs = ["clone", srcuri, destdir] ++ branchArgs @@ -518,22 +526,25 @@ vcsGit = -- is needed because sometimes `git submodule sync` does not actually -- update the submodule source URL. Detailed description here: -- https://git.coop/-/snippets/85 - git localDir $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg - let gitModulesDir = localDir ".git" "modules" - gitModulesExists <- doesDirectoryExist gitModulesDir - when gitModulesExists $ + let dotGitModulesPath = localDir ".git" "modules" + gitModulesPath = localDir ".gitmodules" + + -- Remove any `.git/modules` if they exist. + dotGitModulesExists <- doesDirectoryExist dotGitModulesPath + when dotGitModulesExists $ do + git localDir $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg if buildOS == Windows then do -- Windows can't delete some git files #10182 void $ Process.createProcess_ "attrib" $ Process.shell $ - "attrib -s -h -r " <> gitModulesDir <> "\\*.* /s /d" + "attrib -s -h -r " <> dotGitModulesPath <> "\\*.* /s /d" catch - (removePathForcibly gitModulesDir) - (\e -> if isPermissionError e then removePathForcibly gitModulesDir else throw e) - else removeDirectoryRecursive gitModulesDir + (removePathForcibly dotGitModulesPath) + (\e -> if isPermissionError e then removePathForcibly dotGitModulesPath else throw e) + else removeDirectoryRecursive dotGitModulesPath -- If we want a particular branch or tag, fetch it. ref <- case srpBranch `mplus` srpTag of @@ -581,9 +592,13 @@ vcsGit = , "--" ] - git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg - git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg - git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + -- We need to check if `.gitmodules` exists _after_ the `git reset` call. + gitModulesExists <- doesFileExist gitModulesPath + when gitModulesExists $ do + git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg + git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"] + git localDir $ ["clean", "-ffxdq"] where git :: FilePath -> [String] -> IO () diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index 65ef835837a..4f7ff569a5d 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs @@ -923,10 +923,7 @@ vcsTestDriverGit , mkVcsTmpDir = tmpDir } , vcsAddSubmodule = \_ source dest -> do - destExists <- - (||) - <$> doesFileExist (repoRoot dest) - <*> doesDirectoryExist (repoRoot dest) + destExists <- doesPathExist $ repoRoot dest when destExists $ gitQuiet ["rm", "--force", dest] -- If there is an old submodule git dir with the same name, remove it. -- It most likely has a different URL and `git submodule add` will fai. @@ -995,16 +992,23 @@ vcsTestDriverGit verboseArg = ["--quiet" | verbosity < Verbosity.normal] submoduleGitDir path = repoRoot ".git" "modules" path + + dotGitModulesPath = repoRoot ".git" "modules" + gitModulesPath = repoRoot ".gitmodules" + deinitAndRemoveCachedSubmodules = do - gitQuiet ["submodule", "deinit", "--force", "--all"] - let gitModulesDir = repoRoot ".git" "modules" - gitModulesExists <- doesDirectoryExist gitModulesDir - when gitModulesExists $ removeDirectoryRecursive gitModulesDir + dotGitModulesExists <- doesDirectoryExist dotGitModulesPath + when dotGitModulesExists $ do + git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg + removeDirectoryRecursive dotGitModulesPath + updateSubmodulesAndCleanup = do - gitQuiet ["submodule", "sync", "--recursive"] - gitQuiet ["submodule", "update", "--init", "--recursive", "--force"] - -- Note: We need to manually add `verboseArg` here so that the embedded `git clean` command includes it as well. - gitQuiet $ ["submodule", "foreach", "--recursive", "git clean -ffxdq"] ++ verboseArg + gitModulesExists <- doesFileExist gitModulesPath + when gitModulesExists $ do + gitQuiet ["submodule", "sync", "--recursive"] + gitQuiet ["submodule", "update", "--init", "--recursive", "--force"] + -- Note: We need to manually add `verboseArg` here so that the embedded `git clean` command includes it as well. + gitQuiet $ ["submodule", "foreach", "--recursive", "git clean -ffxdq"] ++ verboseArg gitQuiet ["clean", "-ffxdq"] type MTimeChange = Int diff --git a/changelog.d/pr-10590 b/changelog.d/pr-10590 new file mode 100644 index 00000000000..5121bbfb959 --- /dev/null +++ b/changelog.d/pr-10590 @@ -0,0 +1,14 @@ +--- +synopsis: "Don't run submodule commands unless necessary" +packages: [cabal-install] +prs: 10590 +--- + +When `cabal` clones a Git repo for a `source-repository-package` listed in a +`cabal.project`, it will run various commands to check out the correct +revision, initialize submodules if they're present, and so on. + +Now, `cabal` will avoid running `git submodule` commands unless the cloned +repository contains a `.gitmodules` file. This will declutter `cabal`'s debug +output by running fewer commands. +