Modifying the implementation as per issue #7405

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/main/Main.hs

@@ -249,7 +249,6 @@ mainWorker args = do
 
       ] ++ concat
       [ newCmd  CmdConfigure.configureCommand   CmdConfigure.configureAction
-      , newCmd  CmdConfigure.reconfigureCommand CmdConfigure.reconfigureAction
       , newCmd  CmdUpdate.updateCommand         CmdUpdate.updateAction
       , newCmd  CmdBuild.buildCommand           CmdBuild.buildAction
       , newCmd  CmdRepl.replCommand             CmdRepl.replAction

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

@@ -5,28 +5,23 @@ module Distribution.Client.CmdConfigure (
     configureCommand,
     configureAction,
     configureAction',
-    reconfigureCommand,
-    reconfigureAction,
-    reconfigureAction'
   ) 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, 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 )
 
@@ -101,142 +96,32 @@ configureAction flags extraArgs globalFlags = do
 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
 
-    baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
-
-    -- 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
-
-    -- 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
-
-    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
-
-    return (baseCtx, cliConfig)
-  where
-    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags
-                  mempty -- ClientInstallFlags, not needed here
-    quote s = "'" <> s <> "'"
+    let overwrites = fromFlagOrDefault False $ configOverwrite configExFlags
+        appends    = fromFlagOrDefault False $ configAppend    configExFlags
+        backup     = localFile ++ "~"
 
-reconfigureCommand :: CommandUI (NixStyleFlags ())
-reconfigureCommand = CommandUI {
-  commandName         = "v2-reconfigure",
-  commandSynopsis     = "Add extra project configuration",
-  commandUsage        = usageAlternatives "v2-reconfigure" [ "[FLAGS]" ],
-  commandDescription  = Just $ \_ -> wrapText $
-        "Adjust how the project is built by setting additional package flags "
-     ++ "and other flags.\n\n"
-
-     ++ "The reconfiguration options are written to the 'cabal.project.local' "
-     ++ "file (or '$project_file.local', if '--project-file' is specified) "
-     ++ "which extends the configuration from the 'cabal.project' file "
-     ++ "(if any).\n\n"
-
-     ++ "The v2-reconfigure command also checks that the project configuration "
-     ++ "will work. In particular it checks that there is a consistent set of "
-     ++ "dependencies for the project as a whole.\n\n"
-
-     ++ "It is never necessary to use the 'v2-reconfigure' command. It is "
-     ++ "merely a convenience in cases where you do not want to specify flags "
-     ++ "to 'v2-build' (and other commands) every time and yet do not want "
-     ++ "to alter the 'cabal.project' persistently.",
-  commandNotes        = Just $ \pname ->
-        "Examples:\n"
-     ++ "  " ++ pname ++ " v2-reconfigure --with-compiler ghc-7.10.3\n"
-     ++ "    Adjust the project configuration to use the given compiler\n"
-     ++ "    program and check the resulting configuration works.\n"
-     ++ "  " ++ pname ++ " v2-reconfigure\n"
-     ++ "    Reset the local configuration to empty and check the overall\n"
-     ++ "    project configuration works.\n"
-
-  , commandDefaultFlags = defaultNixStyleFlags ()
-  , commandOptions      = filter (\o -> optionName o /= "ignore-project")
-                        . nixStyleOptions (const [])
-  }
-
-reconfigureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-reconfigureAction flags extraArgs globalFlags = do
-  reconf <- reconfigureAction' flags extraArgs globalFlags
-  let go (baseCtx, projConfig) = 
-        writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig
-
-  either go go reconf
-
-reconfigureAction' 
-    :: NixStyleFlags () 
-    -> [String] 
-    -> GlobalFlags 
-    -> IO (Either (ProjectBaseContext, ProjectConfig) (ProjectBaseContext, ProjectConfig))
-reconfigureAction' flags@NixStyleFlags {..} extraArgs globalFlags = do
-  baseCtx <- establishProjectBaseContext v cliConfig OtherCommand
-
-  let localFile = distProjectFile (distDirLayout baseCtx) "local"
-
-  exists <- doesFileExist localFile
-  if not exists
-    then do
+    when (exists && not overwrites) $ do
       notice v $
-        quote (takeFileName localFile)
-        <> " doesn't exist, calling configure instead."
-
-      -- @configureAction'@ is called, as opposed to @configureAction@, to avoid
-      -- calling on the writing function for configure, thusly maintaining the 
-      -- separation on the behaviour that modify files
-      Left <$> configureAction' flags extraArgs globalFlags
-  
-    else do
-      conf <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
-        readProjectLocalExtraConfig v (distDirLayout baseCtx)
-
-      buildCtx <- runProjectPreBuildPhase v baseCtx $ \plan -> 
-        return (plan, Map.empty)
-
-      printPlan v 
-        (baseCtx {buildSettings = (buildSettings baseCtx) {buildSettingDryRun = True}})
-        buildCtx
-
-      return $ Right (baseCtx, conf <> cliConfig)
-      
+        quote (takeFileName localFile) <> " already exists, backing it up to "
+        <> quote (takeFileName backup) <> "."
+      copyFile localFile backup
+
+    -- 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
     v = fromFlagOrDefault normal (configVerbosity configFlags)
-    cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty
+    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,
+        configOverwrite     = combine configOverwrite,
         -- TODO: NubListify
         configExConstraints = lastNonEmpty configExConstraints,
         -- TODO: NubListify

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

@@ -599,6 +599,8 @@ convertToLegacySharedConfig
 
     configExFlags = ConfigExFlags {
       configCabalVersion  = projectConfigCabalVersion,
+      configAppend        = mempty,
+      configOverwrite     = 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,
+    configOverwrite     :: 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 "" ["overwrite"]
+      "the backup of the config file before any alterations"
+      configOverwrite (\v flags -> flags { configOverwrite = v })
+      (boolOpt [] [])
   , option [] ["constraint"]
       "Specify constraints on a package (version, installed/source, flags)"
       configExConstraints (\v flags -> flags { configExConstraints = v })