Add symlinkableBinary

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

@@ -55,6 +55,7 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.InstallSymlink
   ( promptRun
   , symlinkBinary
+  , symlinkableBinary
   , trySymlink
   )
 import Distribution.Client.NixStyleOptions
@@ -1029,12 +1030,27 @@ installUnitExes
   mkFinalExeName
   installdir
   installMethod
-  (unit, components) =
-    traverse_ installAndWarn exes
+  (unit, components) = do
+    symlinkables :: [Bool] <- traverse symlinkable exes
+    if and symlinkables
+      then traverse_ installAndWarn exes
+      else traverse_ warnAbout (zip symlinkables exes)
     where
       exes = catMaybes $ (exeMaybe . fst) <$> components
       exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
       exeMaybe _ = Nothing
+
+      symlinkable exe =
+          symlinkableBinary
+            overwritePolicy
+            installdir
+            (mkSourceBinDir unit)
+            (mkExeName exe)
+            (mkFinalExeName exe)
+
+      warnAbout (True, _) = return ()
+      warnAbout (False, exe) = die' verbosity (errorMessage exe)
+
       installAndWarn exe = do
         success <-
           installBuiltExe
@@ -1045,20 +1061,21 @@ installUnitExes
             (mkFinalExeName exe)
             installdir
             installMethod
-        let errorMessage = case overwritePolicy of
-              NeverOverwrite ->
-                "Path '"
-                  <> (installdir </> prettyShow exe)
-                  <> "' already exists. "
-                  <> "Use --overwrite-policy=always to overwrite."
-              -- This shouldn't even be possible, but we keep it in case
-              -- symlinking/copying logic changes
-              _ ->
-                case installMethod of
-                  InstallMethodSymlink -> "Symlinking"
-                  InstallMethodCopy ->
-                    "Copying" <> " '" <> prettyShow exe <> "' failed."
-        unless success $ die' verbosity errorMessage
+        unless success $ die' verbosity (errorMessage exe)
+
+      errorMessage exe = case overwritePolicy of
+        NeverOverwrite ->
+          "Path '"
+            <> (installdir </> prettyShow exe)
+            <> "' already exists. "
+            <> "Use --overwrite-policy=always to overwrite."
+        -- This shouldn't even be possible, but we keep it in case
+        -- symlinking/copying logic changes
+        _ ->
+          case installMethod of
+            InstallMethodSymlink -> "Symlinking"
+            InstallMethodCopy ->
+              "Copying" <> " '" <> prettyShow exe <> "' failed."
 
 -- | Install a specific exe.
 installBuiltExe

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

@@ -18,6 +18,7 @@
 module Distribution.Client.InstallSymlink
   ( symlinkBinaries
   , symlinkBinary
+  , symlinkableBinary
   , trySymlink
   , promptRun
   ) where
@@ -247,6 +248,65 @@ symlinkBinaries
       cinfo = compilerInfo comp
       (CompilerId compilerFlavor _) = compilerInfoId cinfo
 
+-- | How to handle symlinking a binary.
+onSymlinkBinary
+  :: IO a
+  -> IO a
+  -> IO a
+  -> IO a
+  -> OverwritePolicy
+  -- ^ Whether to force overwrite an existing file
+  -> FilePath
+  -- ^ The canonical path of the public bin dir eg
+  --   @/home/user/bin@
+  -> FilePath
+  -- ^ The canonical path of the private bin dir eg
+  --   @/home/user/.cabal/bin@
+  -> FilePath
+  -- ^ The name of the executable to go in the public bin
+  --   dir, eg @foo@
+  -> String
+  -- ^ The name of the executable to in the private bin
+  --   dir, eg @foo-1.0@
+  -> IO a
+onSymlinkBinary onMissing onOverwrite onNever onPrompt overwritePolicy publicBindir privateBindir publicName privateName = do
+  ok <-
+    targetOkToOverwrite
+      (publicBindir </> publicName)
+      (privateBindir </> privateName)
+  case ok of
+    NotExists -> onMissing
+    OkToOverwrite -> onOverwrite
+    NotOurFile ->
+      case overwritePolicy of
+        NeverOverwrite -> onNever
+        AlwaysOverwrite -> onOverwrite
+        PromptOverwrite -> onPrompt
+
+-- | Can we symlink a binary?
+symlinkableBinary
+  :: OverwritePolicy
+  -- ^ Whether to force overwrite an existing file
+  -> FilePath
+  -- ^ The canonical path of the public bin dir eg
+  --   @/home/user/bin@
+  -> FilePath
+  -- ^ The canonical path of the private bin dir eg
+  --   @/home/user/.cabal/bin@
+  -> FilePath
+  -- ^ The name of the executable to go in the public bin
+  --   dir, eg @foo@
+  -> String
+  -- ^ The name of the executable to in the private bin
+  --   dir, eg @foo-1.0@
+  -> IO Bool
+  -- ^ If creating the symlink would be succeed, being optimistic that the user
+  -- will agree if prompted to overwrite.
+symlinkableBinary overwritePolicy publicBindir privateBindir publicName privateName = do
+  onSymlinkBinary
+    (return True) (return True) (return False) (return True)
+    overwritePolicy publicBindir privateBindir publicName privateName 
+
 -- | Symlink binary.
 --
 -- The paths are take in pieces, so we can make relative link when possible.
@@ -271,26 +331,21 @@ symlinkBinary
   --   not own. Other errors like permission errors just
   --   propagate as exceptions.
 symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do
-  ok <-
-    targetOkToOverwrite
-      (publicBindir </> publicName)
-      (privateBindir </> privateName)
-  case ok of
-    NotExists -> mkLink
-    OkToOverwrite -> overwrite
-    NotOurFile ->
-      case overwritePolicy of
-        NeverOverwrite -> return False
-        AlwaysOverwrite -> overwrite
-        PromptOverwrite -> maybeOverwrite
+  onSymlinkBinary
+    mkLink overwrite (return False) maybeOverwrite
+    overwritePolicy publicBindir privateBindir publicName privateName 
   where
     relativeBindir = makeRelative publicBindir privateBindir
+
     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 =
       promptRun