Address PR feedback

haskell · Nov 22, 2021 · 9f594be · 9f594be
1 parent 35da53a
commit 9f594be
Show file tree

Hide file tree

Showing 2 changed files with 23 additions and 18 deletions.
diff --git 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
@@ -16,6 +16,7 @@ module Distribution.Client.InstallSymlink (
     symlinkBinaries,
     symlinkBinary,
     trySymlink,
+    promptRun
   ) where
 
 import Distribution.Client.Compat.Prelude hiding (ioError)
@@ -193,24 +194,31 @@ 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
         AlwaysOverwrite -> overwrite
         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