Add prompt strategy for --overwrite-policy

cabal-install/changelog

@@ -1,5 +1,9 @@
 -*-change-log-*-
 
+???
+	* Add "prompt" strategy when symlinking binaries.
+	  after moving them (#5631).
+
 3.6.2.0 Emily Pillmore <emilypi@cohomolo.gy> October 2021
 	* See https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.6.2.0.md
 
@@ -97,7 +101,7 @@
 	  build-tool dependency if they also happen to contain a buildable
 	  public lib. (#5379,#5604)
 	* Fixed a Windows bug where cabal-install tried to copy files
-	  after moving them (#5631).
+	after moving them (#5631).
 	* 'cabal v2-repl' now works for indefinite (in the Backpack sense) components. (#5619)
 	* Set data dir environment variable for tarballs and remote repos (#5469)
 	* Fix monolithic inplace build tool PATH (#5633)

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

@@ -140,6 +140,8 @@ import System.Directory
          , removeFile, removeDirectory, copyFile )
 import System.FilePath
          ( (</>), (<.>), takeDirectory, takeBaseName )
+import Distribution.Client.Init.Types (DefaultPrompt(MandatoryPrompt))
+import Distribution.Client.Init.Prompt (promptYesNo)
 
 installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
 installCommand = CommandUI
@@ -781,7 +783,7 @@ installUnitExes verbosity overwritePolicy
               <> "Use --overwrite-policy=always to overwrite."
             -- This shouldn't even be possible, but we keep it in case
             -- symlinking/copying logic changes
-            AlwaysOverwrite ->
+            _ ->
               case installMethod of
                 InstallMethodSymlink -> "Symlinking"
                 InstallMethodCopy    ->
@@ -816,7 +818,8 @@ installBuiltExe verbosity overwritePolicy
   exists <- doesPathExist destination
   case (exists, overwritePolicy) of
     (True , NeverOverwrite ) -> pure False
-    (True , AlwaysOverwrite) -> remove >> copy
+    (True , AlwaysOverwrite) -> overwrite
+    (True , PromptOverwrite) -> maybeOverwrite
     (False, _              ) -> copy
   where
     source      = sourceDir </> exeName
@@ -827,6 +830,14 @@ installBuiltExe verbosity overwritePolicy
       then removeDirectory destination
       else removeFile      destination
     copy = copyFile source destination >> pure True
+    overwrite :: IO Bool
+    overwrite = remove >> copy
+    maybeOverwrite :: IO Bool
+    maybeOverwrite = do
+      a <- promptYesNo
+        "Existing file found while installing executable. Do you want to unlink that file? (y/n)"
+        MandatoryPrompt
+      if a then overwrite else pure a
 
 -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
 entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]

cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs

@@ -65,7 +65,7 @@ clientInstallOptions _ =
   , option [] ["overwrite-policy"]
     "How to handle already existing symlinks."
     cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })
-    $ reqArg "always|never"
+    $ reqArg "always|never|prompt"
         (parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec)) 
         (map prettyShow . flagToList)
   , option [] ["install-method"]

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

@@ -62,6 +62,8 @@ import Control.Exception
 
 import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )
 import Distribution.Client.Types.OverwritePolicy
+import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) )
+import Distribution.Client.Init.Prompt ( promptYesNo )
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BS8
@@ -195,12 +197,20 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName
     OkToOverwrite     -> rmLink >> mkLink >> return True
     NotOurFile ->
       case overwritePolicy of
-        NeverOverwrite  ->                     return False
-        AlwaysOverwrite -> rmLink >> mkLink >> return True
+        NeverOverwrite  -> return False
+        AlwaysOverwrite -> overwrite
+        PromptOverwrite -> maybeOverwrite
   where
     relativeBindir = makeRelative publicBindir privateBindir
     mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)
     rmLink = removeFile (publicBindir </> publicName)
+    overwrite = True <$ (rmLink *> mkLink)
+    maybeOverwrite :: IO Bool
+    maybeOverwrite = do
+      a <- promptYesNo
+        "Existing file found while installing symlink. Do you want to unlink that file? (y/n)"
+        MandatoryPrompt
+      if a then overwrite else pure a
 
 -- | Check a file path of a symlink that we would like to create to see if it
 -- is OK. For it to be OK to overwrite it must either not already exist yet or

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

@@ -10,6 +10,7 @@ import qualified Text.PrettyPrint                as PP
 data OverwritePolicy
     = NeverOverwrite
     | AlwaysOverwrite
+    | PromptOverwrite
   deriving (Show, Eq, Generic, Bounded, Enum)
 
 instance Binary OverwritePolicy
@@ -21,8 +22,10 @@ instance Parsec OverwritePolicy where
         case name of
             "always" -> pure AlwaysOverwrite
             "never"  -> pure NeverOverwrite
+            "prompt" -> pure PromptOverwrite
             _        -> P.unexpected $ "OverwritePolicy: " ++ name
 
 instance Pretty OverwritePolicy where
     pretty NeverOverwrite  = PP.text "never"
     pretty AlwaysOverwrite = PP.text "always"
+    pretty PromptOverwrite = PP.text "prompt"