From c610d7f3943babdde030948ad657e83ecf6b5583 Mon Sep 17 00:00:00 2001
From: Phil de Joux <philderbeast@gmail.com>
Date: Sun, 17 Sep 2023 09:31:01 -0400
Subject: [PATCH] Replace symlinkable with symlink taking InstallExe

---
 .../src/Distribution/Client/CmdInstall.hs     | 69 +++++++++----------
 1 file changed, 32 insertions(+), 37 deletions(-)

diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
index e8daff73859..10d548f75d6 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -1088,6 +1088,34 @@ disableTestsBenchsByDefault configFlags =
     , configBenchmarks = Flag False <> configBenchmarks configFlags
     }
 
+symlink :: OverwritePolicy -> InstallExe -> UnitId -> UnqualComponentName -> Symlink
+symlink
+  overwritePolicy
+  InstallExe{installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
+  unit
+  exe =
+    Symlink
+      overwritePolicy
+      installDir
+      (mkSourceBinDir unit)
+      (mkExeName exe)
+      (mkFinalExeName exe)
+
+errorMessage :: Pretty a => OverwritePolicy -> InstallMethod -> FilePath -> a -> String
+errorMessage overwritePolicy installMethod installdir 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."
+
 -- | Check if we can Symlink/copy every exe from a package from the store to a given location
 installableUnitExes
   :: Verbosity
@@ -1100,9 +1128,9 @@ installableUnitExes
 installableUnitExes
   verbosity
   overwritePolicy
-  InstallExe{installMethod, installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
+  installExe@InstallExe{installMethod, installDir}
   (unit, components) = do
-    symlinkables :: [Bool] <- traverse (symlinkable overwritePolicy mkSourceBinDir mkExeName mkFinalExeName installDir unit) exes
+    symlinkables :: [Bool] <- traverse (symlinkableBinary . symlink overwritePolicy installExe unit) exes
     traverse_ warnAbout (zip symlinkables exes)
     where
       exes = catMaybes $ (exeMaybe . fst) <$> components
@@ -1125,9 +1153,9 @@ installUnitExes
 installUnitExes
   verbosity
   overwritePolicy
-  InstallExe{installMethod, installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
+  installExe@InstallExe{installMethod, installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
   (unit, components) = do
-    symlinkables :: [Bool] <- traverse (symlinkable overwritePolicy mkSourceBinDir mkExeName mkFinalExeName installDir unit) exes
+    symlinkables :: [Bool] <- traverse (symlinkableBinary . symlink overwritePolicy installExe unit) exes
     if and symlinkables
       then traverse_ installAndWarn exes
       else traverse_ warnAbout (zip symlinkables exes)
@@ -1151,39 +1179,6 @@ installUnitExes
             installMethod
         unless success $ die' verbosity (errorMessage overwritePolicy installMethod installDir exe)
 
-symlinkable
-  :: OverwritePolicy
-  -> (UnitId -> FilePath)
-  -> (UnqualComponentName -> FilePath)
-  -> (UnqualComponentName -> FilePath)
-  -> FilePath
-  -> UnitId
-  -> UnqualComponentName
-  -> IO Bool
-symlinkable overwritePolicy mkSourceBinDir mkExeName mkFinalExeName installdir unit exe =
-    symlinkableBinary
-      (Symlink
-        overwritePolicy
-        installdir
-        (mkSourceBinDir unit)
-        (mkExeName exe)
-        (mkFinalExeName exe))
-
-errorMessage :: Pretty a => OverwritePolicy -> InstallMethod -> FilePath -> a -> String
-errorMessage overwritePolicy installMethod installdir 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
   :: Verbosity