VCS: Don't run submodule commands unless necessary

Running `git submodule` commands is harmless but clutters up the logs,
making the tests difficult to debug when run in verbose-mode.

Doesn't seem to impact performance much. I measured a ~1.5% speedup with
this code, which is well within error margins.

See: https://github.com/haskell/cabal/pull/7625/files#r709617991

Author: 9999years

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

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
@@ -516,29 +524,38 @@ 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"]
-      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
+
       when (resetTarget /= "HEAD") $ do
         git localDir fetchArgs -- first fetch the tag if needed
         git localDir setTagArgs
       git localDir resetArgs -- only then reset to the commit
-      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 ()

cabal-install/tests/UnitTests/Distribution/Client/VCS.hs

@@ -874,10 +874,7 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
     , vcsSubmoduleDriver =
         pure . vcsTestDriverGit verbosity vcs' submoduleDir . (submoduleDir </>)
     , vcsAddSubmodule = \_ source dest -> do
-        destExists <-
-          (||)
-            <$> doesFileExist (repoRoot </> dest)
-            <*> doesDirectoryExist (repoRoot </> dest)
+        destExists <- doesPathExist $ repoRoot </> dest
         when destExists $ git ["rm", "-f", 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.
@@ -923,15 +920,22 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
     git' = getProgramInvocationOutput verbosity . gitInvocation
     verboseArg = ["--quiet" | verbosity < Verbosity.normal]
     submoduleGitDir path = repoRoot </> ".git" </> "modules" </> path
+
+    dotGitModulesPath = repoRoot </> ".git" </> "modules"
+    gitModulesPath = repoRoot </> ".gitmodules"
+
     deinitAndRemoveCachedSubmodules = do
-      git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg
-      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
-      git $ ["submodule", "sync", "--recursive"] ++ verboseArg
-      git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg
-      git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]
+      gitModulesExists <- doesFileExist gitModulesPath
+      when gitModulesExists $ do
+        git $ ["submodule", "sync", "--recursive"] ++ verboseArg
+        git $ ["submodule", "update", "--init", "--recursive", "--force"] ++ verboseArg
+        git $ ["submodule", "foreach", "--recursive", "git clean -ffxdq"] ++ verboseArg
       git $ ["clean", "-ffxdq"] ++ verboseArg
 
 type MTimeChange = Int