Merge commit 'dfc1d354b8923e4a22757fc2eb0ea48ce8cb5aa9' into mattp/gl…

…ob-and-preproc

.github/workflows/validate.yml

@@ -478,6 +478,7 @@ jobs:
         with:
           pattern: cabal-*
           path: binaries
+          merge-multiple: true
 
       - name: Create GitHub prerelease
         uses: softprops/action-gh-release@v2
@@ -502,6 +503,7 @@ jobs:
       with:
         pattern: cabal-*
         path: binaries
+        merge-multiple: true
 
     - run: |
         # bash-ism, but we forced bash above

Cabal/src/Distribution/Simple/PreProcess.hs

@@ -292,63 +292,66 @@ preprocessFile
   -- ^ fail on missing file
   -> IO ()
 preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do
-  -- look for files in the various source dirs with this module name
-  -- and a file extension of a known preprocessor
-  psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile
-  case psrcFiles of
-    -- no preprocessor file exists, look for an ordinary source file
-    -- just to make sure one actually exists at all for this module.
-
-    -- Note [Dodgy build dirs for preprocessors]
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-    -- By looking in the target/output build dir too, we allow
-    -- source files to appear magically in the target build dir without
-    -- any corresponding "real" source file. This lets custom Setup.hs
-    -- files generate source modules directly into the build dir without
-    -- the rest of the build system being aware of it (somewhat dodgy)
+  bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (searchLoc ++ [buildAsSrcLoc]) baseFile
+  case bsrcFiles of
+    -- found a non-processable file in one of the source dirs
+    Just _ -> do
+      pure ()
     Nothing -> do
-      bsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes (buildAsSrcLoc : searchLoc) baseFile
-      case (bsrcFiles, failOnMissing) of
-        (Nothing, True) ->
-          dieWithException verbosity $
-            CantFindSourceForPreProcessFile $
-              "can't find source for "
-                ++ getSymbolicPath baseFile
-                ++ " in "
-                ++ intercalate ", " (map getSymbolicPath searchLoc)
-        _ -> return ()
-    -- found a pre-processable file in one of the source dirs
-    Just (psrcLoc, psrcRelFile) -> do
-      let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile
-          psrcFile = psrcLoc </> psrcRelFile
-          pp =
-            fromMaybe
-              (error "Distribution.Simple.PreProcess: Just expected")
-              (lookup (Suffix $ safeTail ext) handlers)
-      -- Preprocessing files for 'sdist' is different from preprocessing
-      -- for 'build'.  When preprocessing for sdist we preprocess to
-      -- avoid that the user has to have the preprocessors available.
-      -- ATM, we don't have a way to specify which files are to be
-      -- preprocessed and which not, so for sdist we only process
-      -- platform independent files and put them into the 'buildLoc'
-      -- (which we assume is set to the temp. directory that will become
-      -- the tarball).
-      -- TODO: eliminate sdist variant, just supply different handlers
-      when (not forSDist || forSDist && platformIndependent pp) $ do
-        -- look for existing pre-processed source file in the dest dir to
-        -- see if we really have to re-run the preprocessor.
-        ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile
-        recomp <- case ppsrcFiles of
-          Nothing -> return True
-          Just ppsrcFile ->
-            i psrcFile `moreRecentFile` i ppsrcFile
-        when recomp $ do
-          let destDir = i buildLoc </> takeDirectory srcStem
-          createDirectoryIfMissingVerbose verbosity True destDir
-          runPreProcessorWithHsBootHack
-            pp
-            (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile)
-            (getSymbolicPath $ buildLoc, srcStem <.> "hs")
+      -- look for files in the various source dirs with this module name
+      -- and a file extension of a known preprocessor
+      psrcFiles <- findFileCwdWithExtension' mbWorkDir (map fst handlers) searchLoc baseFile
+      case psrcFiles of
+        -- no preprocessor file exists, look for an ordinary source file
+        -- just to make sure one actually exists at all for this module.
+
+        -- Note [Dodgy build dirs for preprocessors]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- By looking in the target/output build dir too, we allow
+        -- source files to appear magically in the target build dir without
+        -- any corresponding "real" source file. This lets custom Setup.hs
+        -- files generate source modules directly into the build dir without
+        -- the rest of the build system being aware of it (somewhat dodgy)
+        Nothing ->
+          when failOnMissing $ do
+            dieWithException verbosity $
+              CantFindSourceForPreProcessFile $
+                "can't find source for "
+                  ++ getSymbolicPath baseFile
+                  ++ " in "
+                  ++ intercalate ", " (map getSymbolicPath searchLoc)
+        Just (psrcLoc, psrcRelFile) -> do
+          let (srcStem, ext) = splitExtension $ getSymbolicPath psrcRelFile
+              psrcFile = psrcLoc </> psrcRelFile
+              pp =
+                fromMaybe
+                  (error "Distribution.Simple.PreProcess: Just expected")
+                  (lookup (Suffix $ safeTail ext) handlers)
+          -- Preprocessing files for 'sdist' is different from preprocessing
+          -- for 'build'.  When preprocessing for sdist we preprocess to
+          -- avoid that the user has to have the preprocessors available.
+          -- ATM, we don't have a way to specify which files are to be
+          -- preprocessed and which not, so for sdist we only process
+          -- platform independent files and put them into the 'buildLoc'
+          -- (which we assume is set to the temp. directory that will become
+          -- the tarball).
+          -- TODO: eliminate sdist variant, just supply different handlers
+          when (not forSDist || forSDist && platformIndependent pp) $ do
+            -- look for existing pre-processed source file in the dest dir to
+            -- see if we really have to re-run the preprocessor.
+            ppsrcFiles <- findFileCwdWithExtension mbWorkDir builtinSuffixes [buildAsSrcLoc] baseFile
+            recomp <- case ppsrcFiles of
+              Nothing -> return True
+              Just ppsrcFile ->
+                i psrcFile `moreRecentFile` i ppsrcFile
+            when recomp $ do
+              let destDir = i buildLoc </> takeDirectory srcStem
+              createDirectoryIfMissingVerbose verbosity True destDir
+              runPreProcessorWithHsBootHack
+                pp
+                (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile)
+                (getSymbolicPath $ buildLoc, srcStem <.> "hs")
+
   where
     i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
     buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)

cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs

@@ -165,14 +165,14 @@ guessAuthorEmail = guessGitInfo "user.email"
 
 guessGitInfo :: Interactive m => String -> m (Maybe String)
 guessGitInfo target = do
-  localInfo <- readProcessWithExitCode "git" ["config", "--local", target] ""
-  if null $ snd' localInfo
-    then do
-      globalInfo <- readProcessWithExitCode "git" ["config", "--global", target] ""
-      case fst' globalInfo of
-        ExitSuccess -> return $ Just (trim $ snd' globalInfo)
-        _ -> return Nothing
-    else return $ Just (trim $ snd' localInfo)
-  where
-    fst' (x, _, _) = x
-    snd' (_, x, _) = x
+  localInfo <- maybeReadProcessWithExitCode "git" ["config", "--local", target] ""
+  case localInfo of
+    Nothing -> return Nothing
+    Just (_, localStdout, _) ->
+      if null localStdout
+        then do
+          globalInfo <- maybeReadProcessWithExitCode "git" ["config", "--global", target] ""
+          case globalInfo of
+            Just (ExitSuccess, globalStdout, _) -> return $ Just (trim globalStdout)
+            _ -> return Nothing
+        else return $ Just (trim localStdout)

cabal-install/src/Distribution/Client/Init/Types.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- |
 -- Module      :  Distribution.Client.Init.Types
@@ -346,6 +347,7 @@ class Monad m => Interactive m where
   doesFileExist :: FilePath -> m Bool
   canonicalizePathNoThrow :: FilePath -> m FilePath
   readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String)
+  maybeReadProcessWithExitCode :: FilePath -> [String] -> String -> m (Maybe (ExitCode, String, String))
   getEnvironment :: m [(String, String)]
   getCurrentYear :: m Integer
   listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath]
@@ -389,6 +391,7 @@ instance Interactive PromptIO where
   doesFileExist = liftIO <$> P.doesFileExist
   canonicalizePathNoThrow = liftIO <$> P.canonicalizePathNoThrow
   readProcessWithExitCode a b c = liftIO $ Process.readProcessWithExitCode a b c
+  maybeReadProcessWithExitCode a b c = liftIO $ (Just <$> Process.readProcessWithExitCode a b c) `P.catch` const @_ @IOError (pure Nothing)
   getEnvironment = liftIO P.getEnvironment
   getCurrentYear = liftIO P.getCurrentYear
   listFilesInside test dir = do
@@ -438,6 +441,7 @@ instance Interactive PurePrompt where
   readProcessWithExitCode !_ !_ !_ = do
     input <- pop
     return (ExitSuccess, input, "")
+  maybeReadProcessWithExitCode a b c = Just <$> readProcessWithExitCode a b c
   getEnvironment = fmap (map read) popList
   getCurrentYear = fmap read pop
   listFilesInside pred' !_ = do

cabal-testsuite/PackageTests/Init/init-without-git.out

@@ -0,0 +1 @@
+# cabal init

cabal-testsuite/PackageTests/Init/init-without-git.test.hs

@@ -0,0 +1,22 @@
+import Test.Cabal.Prelude
+import System.Directory
+import System.FilePath
+import Distribution.Simple.Utils
+import Distribution.Verbosity
+
+-- Test cabal init when git is not installed
+main = do
+  skipIfWindows "Might fail on windows."
+  tmp <- getTemporaryDirectory
+  withTempDirectory normal tmp "bin" $
+    \bin -> cabalTest $
+      do
+        ghc_path <- programPathM ghcProgram
+        cabal_path <- programPathM cabalProgram
+        withSymlink ghc_path (bin </> "ghc") . withSymlink cabal_path (bin </> "cabal") .
+          withEnv [("PATH", Just bin)] $ do
+            cwd <- fmap testSourceCopyDir getTestEnv
+
+            void . withDirectory cwd $ do
+              cabalWithStdin "init" ["-i"]
+                "2\n\n5\n\n\n2\n\n\n\n\n\n\n\n\n\n"

changelog.d/pr-10486

@@ -0,0 +1,12 @@
+synopsis: Fix a bug that causes `cabal init` to crash if `git` is not installed
+packages: cabal-install
+prs: #10486
+issues: #10484 #8478
+significance:
+
+description: {
+
+- `cabal init` tries to use `git config` to guess the user's name and email.
+  It no longer crashes if there is no executable named `git` on $PATH.
+
+}