[commit: Cabal] master: improved error handling for multiple installs (1c8139d)

[Ian Lynagh]

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

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/1c8139d8a77c9add8ee05434ed3ae5f9efe9c0b6

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

commit 1c8139d8a77c9add8ee05434ed3ae5f9efe9c0b6
Author: ijones <ijones at syntaxpolice.org>
Date:   Mon Dec 31 21:03:03 2007 +0000

    improved error handling for multiple installs
    When installing multiple packages, don't quit just after the first
    error, but rather collect the list of packages that failed to install
    continue installing whatever packages we can, and provide an error
    message at the end.

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

 cabal-install/Hackage/Install.hs |   17 +++++++++++++++--
 1 files changed, 15 insertions(+), 2 deletions(-)

diff --git a/cabal-install/Hackage/Install.hs b/cabal-install/Hackage/Install.hs
index 272c38e..9c15950 100644
--- a/cabal-install/Hackage/Install.hs
+++ b/cabal-install/Hackage/Install.hs
@@ -14,7 +14,7 @@ module Hackage.Install
     ( install
     ) where
 
-import Control.Exception (bracket_)
+import Control.Exception (bracket_, try)
 import Control.Monad (when)
 import Data.Monoid (Monoid(mempty))
 import System.Directory (getTemporaryDirectory, createDirectoryIfMissing
@@ -71,7 +71,20 @@ installPackages :: ConfigFlags
                 -> Cabal.ConfigFlags -- ^Options which will be passed to every package.
                 -> [(PkgInfo,FlagAssignment)] -- ^ (Package, list of configure options)
                 -> IO ()
-installPackages cfg configFlags = mapM_ (installPkg cfg configFlags)
+installPackages cfg configFlags pkgs = do 
+  errorPackages <- installPackagesErrs pkgs []
+  case errorPackages of
+    [] -> return ()
+    pkgs -> do let errorMsg = concat $ "Error: some packages failed to install:"
+                             : ["\n  " ++ showPackageId (pkgInfoId x) | (x, _) <- pkgs]
+               die errorMsg
+
+  where installPackagesErrs (pkg:pkgs) errPkgs = do
+          maybeInstalled <- try (installPkg cfg configFlags pkg)
+          case maybeInstalled of
+            Left e ->  installPackagesErrs pkgs (pkg:errPkgs)
+            Right _ -> installPackagesErrs pkgs errPkgs
+        installPackagesErrs [] ers = return ers
 
 
 {-|