[commit: Cabal] master: Warn about symlinks that could not be created (b0ff24f)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/b0ff24f454ace1acaa16e667c618e7b915422367

>---------------------------------------------------------------

commit b0ff24f454ace1acaa16e667c618e7b915422367
Author: Duncan Coutts <duncan at haskell.org>
Date:   Sat Aug 2 13:39:22 2008 +0000

    Warn about symlinks that could not be created

>---------------------------------------------------------------

 cabal-install/Distribution/Client/Install.hs       |   32 +++++++++++++++++-
 .../Distribution/Client/InstallSymlink.hs          |   34 ++++++++++++-------
 2 files changed, 51 insertions(+), 15 deletions(-)

diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index fd96ad6..3b881d7 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -52,6 +52,7 @@ import Distribution.Client.Reporting
 import Distribution.Client.Logging
          ( writeInstallPlanBuildLog )
 import qualified Distribution.Client.InstallSymlink as InstallSymlink
+         ( symlinkBinaries )
 import Paths_cabal_install (getBinDir)
 
 import Distribution.Simple.Compiler
@@ -77,7 +78,8 @@ import Distribution.InstalledPackageInfo
          ( InstalledPackageInfo )
 import Distribution.Version
          ( Version, VersionRange(AnyVersion, ThisVersion) )
-import Distribution.Simple.Utils as Utils (notice, info, die)
+import Distribution.Simple.Utils as Utils
+         ( notice, info, warn, die, intercalate )
 import Distribution.System
          ( buildOS, buildArch )
 import Distribution.Text
@@ -157,8 +159,8 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
                                        pkg mpath useLogFile
         writeInstallPlanBuildReports installPlan'
         writeInstallPlanBuildLog     installPlan'
+        symlinkBinaries verbosity configFlags installFlags installPlan'
         printBuildFailures installPlan'
-        InstallSymlink.symlinkBinaries configFlags installFlags installPlan'
 
   where
     setupScriptOptions index = SetupScriptOptions {
@@ -245,6 +247,32 @@ printDryRun verbosity plan = case unfoldr next plan of
       (pkg:_) -> Just (pkgid, InstallPlan.completed pkgid plan')
         where pkgid = packageId pkg
 
+symlinkBinaries :: Verbosity
+                -> Cabal.ConfigFlags
+                -> InstallFlags
+                -> InstallPlan BuildResult -> IO ()
+symlinkBinaries verbosity configFlags installFlags plan = do
+  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan
+  case failed of
+    [] -> return ()
+    [(_, exe, path)] ->
+      warn verbosity $
+           "could not create a symlink in " ++ bindir ++ " for "
+        ++ exe ++ " because the file exists there already but is not "
+        ++ "managed by cabal. You can create a symlink for this executable "
+        ++ "manually if you wish. The executable file has been installed at "
+        ++ path
+    exes ->
+      warn verbosity $
+           "could not create symlinks in " ++ bindir ++ " for "
+        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]
+        ++ " because the files exist there already and are not "
+        ++ "managed by cabal. You can create symlinks for these executables "
+        ++ "manually if you wish. The executable files have been installed at "
+        ++ intercalate ", " [ path | (_, _, path) <- exes ]
+  where
+    bindir = Cabal.fromFlag (installSymlinkBinDir installFlags)
+
 printBuildFailures :: InstallPlan BuildResult -> IO ()
 printBuildFailures plan =
   case [ (pkg, reason)
diff --git a/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal-install/Distribution/Client/InstallSymlink.hs
index 5c79183..8233427 100644
--- a/cabal-install/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/Distribution/Client/InstallSymlink.hs
@@ -46,7 +46,7 @@ import qualified Distribution.Client.InstallPlan as InstallPlan
 import Distribution.Client.InstallPlan (InstallPlan)
 
 import Distribution.Package
-         ( Package(packageId) )
+         ( PackageIdentifier, Package(packageId) )
 import Distribution.Compiler
          ( CompilerId(..) )
 import qualified Distribution.PackageDescription as PackageDescription
@@ -70,6 +70,8 @@ import System.IO.Error
          ( catch, isDoesNotExistError, ioError )
 import Control.Exception
          ( assert )
+import Data.Maybe
+         ( catMaybes )
 
 -- | We would like by default to install binaries into some location that is on
 -- the user's PATH. For per-user installations on Unix systems that basically
@@ -93,23 +95,29 @@ import Control.Exception
 --
 symlinkBinaries :: ConfigFlags
                 -> InstallFlags
-                -> InstallPlan BuildResult -> IO ()
+                -> InstallPlan BuildResult
+                -> IO [(PackageIdentifier, String, FilePath)]
 symlinkBinaries configFlags installFlags plan =
   case flagToMaybe (installSymlinkBinDir installFlags) of
-    Nothing            -> return ()
+    Nothing            -> return []
     Just symlinkBinDir -> do
       publicBinDir  <- canonicalizePath symlinkBinDir
-      sequence_
+      fmap catMaybes $ sequence
         [ let publicExeName  = PackageDescription.exeName exe
               privateExeName = prefix ++ publicExeName ++ suffix
-              prefix = substTemplate pkg prefixTemplate
-              suffix = substTemplate pkg suffixTemplate
+              prefix = substTemplate pkgid prefixTemplate
+              suffix = substTemplate pkgid suffixTemplate
           in do privateBinDir <- pkgBinDir pkg
-                symlinkBinary
-                  publicBinDir  privateBinDir
-                  publicExeName privateExeName
+                ok <- symlinkBinary
+                        publicBinDir  privateBinDir
+                        publicExeName privateExeName
+                if ok
+                  then return Nothing
+                  else return (Just (pkgid, publicExeName,
+                                     privateBinDir </> privateExeName))
         | InstallPlan.Installed cpkg <- InstallPlan.toList plan
-        , let pkg = pkgDescription cpkg
+        , let pkg   = pkgDescription cpkg
+              pkgid = packageId pkg
         , exe <- PackageDescription.executables pkg
         , PackageDescription.buildable (PackageDescription.buildInfo exe) ]
   where
@@ -137,9 +145,9 @@ symlinkBinaries configFlags installFlags plan =
                            templateDirs
       canonicalizePath (InstallDirs.bindir absoluteDirs)
 
-    substTemplate pkg = InstallDirs.fromPathTemplate
-                      . InstallDirs.substPathTemplate env
-      where env = InstallDirs.initialPathTemplateEnv (packageId pkg) compilerId
+    substTemplate pkgid = InstallDirs.fromPathTemplate
+                        . InstallDirs.substPathTemplate env
+      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId
 
     fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)