From 9f594be790e6cc6fe19485c1d7c655bd09ecf07b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iveren?= <fhi.1990@gmail.com>
Date: Mon, 22 Nov 2021 21:40:31 +0100
Subject: [PATCH] Address PR feedback

---
 .../src/Distribution/Client/CmdInstall.hs     | 13 ++++-----
 .../src/Distribution/Client/InstallSymlink.hs | 28 ++++++++++++-------
 2 files changed, 23 insertions(+), 18 deletions(-)

diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
index 57c96dc4303..7ebe48952e0 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -90,7 +90,7 @@ import Distribution.Client.DistDirLayout
 import Distribution.Client.RebuildMonad
          ( runRebuild )
 import Distribution.Client.InstallSymlink
-         ( symlinkBinary, trySymlink )
+         ( symlinkBinary, trySymlink, promptRun )
 import Distribution.Client.Types.OverwritePolicy
          ( OverwritePolicy (..) )
 import Distribution.Simple.Flag
@@ -140,8 +140,6 @@ 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
@@ -833,11 +831,10 @@ installBuiltExe verbosity overwritePolicy
     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
+    maybeOverwrite
+      = promptRun
+        "Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
+        overwrite
 
 -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
 entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs
index 4c9bf734a63..5acf0092002 100644
--- a/cabal-install/src/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs
@@ -16,6 +16,7 @@ module Distribution.Client.InstallSymlink (
     symlinkBinaries,
     symlinkBinary,
     trySymlink,
+    promptRun
   ) where
 
 import Distribution.Client.Compat.Prelude hiding (ioError)
@@ -193,8 +194,8 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName
   ok <- targetOkToOverwrite (publicBindir </> publicName)
                             (privateBindir </> privateName)
   case ok of
-    NotExists         ->           mkLink >> return True
-    OkToOverwrite     -> rmLink >> mkLink >> return True
+    NotExists         -> mkLink
+    OkToOverwrite     -> overwrite
     NotOurFile ->
       case overwritePolicy of
         NeverOverwrite  -> return False
@@ -202,15 +203,22 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName
         PromptOverwrite -> maybeOverwrite
   where
     relativeBindir = makeRelative publicBindir privateBindir
-    mkLink = createFileLink (relativeBindir </> privateName) (publicBindir   </> publicName)
-    rmLink = removeFile (publicBindir </> publicName)
-    overwrite = True <$ (rmLink *> mkLink)
+    mkLink :: IO Bool
+    mkLink = True <$ createFileLink (relativeBindir </> privateName) (publicBindir </> publicName)
+    rmLink :: IO Bool
+    rmLink = True <$ removeFile (publicBindir </> publicName)
+    overwrite :: IO Bool
+    overwrite = 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
+    maybeOverwrite
+      = promptRun
+        "Existing file found while installing symlink. Do you want to overwrite that file? (y/n)"
+        overwrite
+
+promptRun :: String -> IO Bool -> IO Bool
+promptRun s m = do
+  a <- promptYesNo s MandatoryPrompt
+  if a then m 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