cabal v2-configure, see issue #7405

This commit straightens the v2-configure command:

* Removes the pre-build phase
* Adds two flags, --append and --overwrite

Co-authored-by: Emily Pillmore <emilypi@cohomolo.gy>

Author: ptkato

Cabal/src/Distribution/Simple/Setup.hs

@@ -200,7 +200,6 @@ data ConfigFlags = ConfigFlags {
     -- ProgramDb directly and not via ConfigFlags
     configPrograms_     :: Option' (Last' ProgramDb), -- ^All programs that
                                                       -- @cabal@ may run
-
     configProgramPaths  :: [(String, FilePath)], -- ^user specified programs paths
     configProgramArgs   :: [(String, [String])], -- ^user specified programs args
     configProgramPathExtra :: NubList FilePath,  -- ^Extend the $PATH

cabal-install/src/Distribution/Client/CmdConfigure.hs

@@ -4,25 +4,24 @@
 module Distribution.Client.CmdConfigure (
     configureCommand,
     configureAction,
+    configureAction',
   ) where
 
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
 import System.Directory
 import System.FilePath
-import qualified Data.Map as Map
 
+import Distribution.Simple.Flag
 import Distribution.Client.ProjectOrchestration
 import Distribution.Client.ProjectConfig
-         ( writeProjectLocalExtraConfig )
+         ( writeProjectLocalExtraConfig, readProjectLocalExtraConfig )
 
 import Distribution.Client.NixStyleOptions
          ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
 import Distribution.Client.Setup
-         ( GlobalFlags, ConfigFlags(..) )
-import Distribution.Simple.Flag
-         ( fromFlagOrDefault )
+         ( GlobalFlags, ConfigFlags(..), ConfigExFlags(..) )
 import Distribution.Verbosity
          ( normal )
 
@@ -33,6 +32,8 @@ import Distribution.Simple.Utils
 
 import Distribution.Client.DistDirLayout
          ( DistDirLayout(..) )
+import Distribution.Client.RebuildMonad (runRebuild)
+import Distribution.Client.ProjectConfig.Types
 
 configureCommand :: CommandUI (NixStyleFlags ())
 configureCommand = CommandUI {
@@ -88,61 +89,39 @@ configureCommand = CommandUI {
 -- "Distribution.Client.ProjectOrchestration"
 --
 configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-configureAction flags@NixStyleFlags {..} _extraArgs globalFlags = do
-    --TODO: deal with _extraArgs, since flags with wrong syntax end up there
-
-    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
+configureAction flags extraArgs globalFlags = do
+  (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags
+  writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig
 
-    -- Write out the @cabal.project.local@ so it gets picked up by the
-    -- planning phase. If old config exists, then print the contents
-    -- before overwriting
-
-    let localFile = distProjectFile (distDirLayout baseCtx) "local"
-        -- | Chooses cabal.project.local~, or if it already exists
-        -- cabal.project.local~0, cabal.project.local~1 etc.
-        firstFreeBackup = firstFreeBackup' (0 :: Int)
-        firstFreeBackup' i = do
-          let backup = localFile <> "~" <> (if i <= 0 then "" else show (i - 1))
-          exists <- doesFileExist backup
-          if exists
-            then firstFreeBackup' (i + 1)
-            else return backup
+configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig)
+configureAction' flags@NixStyleFlags {..} _extraArgs globalFlags = do
+    --TODO: deal with _extraArgs, since flags with wrong syntax end up there
+    
+    baseCtx <- establishProjectBaseContext v cliConfig OtherCommand
 
-    -- If cabal.project.local already exists, back up to cabal.project.local~[n]
+    let localFile  = distProjectFile (distDirLayout baseCtx) "local"
+    -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~
     exists <- doesFileExist localFile
-    when exists $ do
-        backup <- firstFreeBackup
-        notice verbosity $
-          quote (takeFileName localFile) <> " already exists, backing it up to "
-          <> quote (takeFileName backup) <> "."
-        copyFile localFile backup
-    writeProjectLocalExtraConfig (distDirLayout baseCtx)
-                                 cliConfig
-
-    buildCtx <-
-      runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan ->
-
-            -- TODO: Select the same subset of targets as 'CmdBuild' would
-            -- pick (ignoring, for example, executables in libraries
-            -- we depend on). But we don't want it to fail, so actually we
-            -- have to do it slightly differently from build.
-            return (elaboratedPlan, Map.empty)
-
-    let baseCtx' = baseCtx {
-                      buildSettings = (buildSettings baseCtx) {
-                        buildSettingDryRun = True
-                      }
-                    }
-
-    -- TODO: Hmm, but we don't have any targets. Currently this prints
-    -- what we would build if we were to build everything. Could pick
-    -- implicit target like "."
-    --
-    -- TODO: should we say what's in the project (+deps) as a whole?
-    printPlan verbosity baseCtx' buildCtx
+    let backups = fromFlagOrDefault True  $ configBackup configExFlags
+        appends = fromFlagOrDefault False $ configAppend configExFlags
+        backupFile = localFile <> "~"
+
+    when (exists && not backups) $ do
+      notice v $
+        quote (takeFileName localFile) <> " already exists, backing it up to "
+        <> quote (takeFileName backupFile) <> "."
+      copyFile localFile backupFile
+
+    -- If the flag @configAppend@ is set to true, append and do not overwrite
+    if exists && appends
+      then do
+        conf <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
+          readProjectLocalExtraConfig v (distDirLayout baseCtx)
+        return (baseCtx, conf <> cliConfig)
+      else
+        return (baseCtx, cliConfig)
   where
-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
+    v = fromFlagOrDefault normal (configVerbosity configFlags)
     cliConfig = commandLineFlagsToProjectConfig globalFlags flags
                   mempty -- ClientInstallFlags, not needed here
     quote s = "'" <> s <> "'"
-

cabal-install/src/Distribution/Client/Config.hs

@@ -419,6 +419,8 @@ instance Semigroup SavedConfig where
 
       combinedSavedConfigureExFlags = ConfigExFlags {
         configCabalVersion  = combine configCabalVersion,
+        configAppend        = combine configAppend,
+        configBackup        = combine configBackup,
         -- TODO: NubListify
         configExConstraints = lastNonEmpty configExConstraints,
         -- TODO: NubListify

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -27,6 +27,7 @@ module Distribution.Client.ProjectConfig (
     -- * Project config files
     readProjectConfig,
     readGlobalConfig,
+    readProjectLocalExtraConfig,
     readProjectLocalFreezeConfig,
     withProjectOrGlobalConfig,
     writeProjectLocalExtraConfig,

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -599,6 +599,8 @@ convertToLegacySharedConfig
 
     configExFlags = ConfigExFlags {
       configCabalVersion  = projectConfigCabalVersion,
+      configAppend        = mempty,
+      configBackup        = mempty,
       configExConstraints = projectConfigConstraints,
       configPreferences   = projectConfigPreferences,
       configSolver        = projectConfigSolver,

cabal-install/src/Distribution/Client/Setup.hs

@@ -599,6 +599,8 @@ configCompilerAux' configFlags =
 --
 data ConfigExFlags = ConfigExFlags {
     configCabalVersion  :: Flag Version,
+    configAppend        :: Flag Bool,
+    configBackup        :: Flag Bool, 
     configExConstraints :: [(UserConstraint, ConstraintSource)],
     configPreferences   :: [PackageVersionConstraint],
     configSolver        :: Flag PreSolver,
@@ -637,6 +639,14 @@ configureExOptions _showOrParseArgs src =
       (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++)
                                     (fmap toFlag parsec))
                         (map prettyShow. flagToList))
+  , option "" ["append"]
+      "appending the new config to the old config file"
+      configAppend (\v flags -> flags { configAppend = v })
+      (boolOpt [] [])
+  , option "" ["backup"]
+      "the backup of the config file before any alterations"
+      configBackup (\v flags -> flags { configBackup = v })
+      (boolOpt [] [])
   , option [] ["constraint"]
       "Specify constraints on a package (version, installed/source, flags)"
       configExConstraints (\v flags -> flags { configExConstraints = v })