From a9247b15bc226af4a20d174f74b6f8a316b8d085 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@community.haskell.org>
Date: Thu, 11 Aug 2016 01:17:40 +0100
Subject: [PATCH] Extend the annotateFailure utility to reduce call-site
 clutter

Make annotateFailure take a maybe log file, and add a
annotateFailureNoLog for the other case. This is a little more future
proof and simplifies things at the call sites.
---
 .../Distribution/Client/ProjectBuilding.hs    | 33 +++++++++++--------
 1 file changed, 20 insertions(+), 13 deletions(-)

diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs
index 5be2e75cc4a..5d3522610eb 100644
--- a/cabal-install/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/Distribution/Client/ProjectBuilding.hs
@@ -725,7 +725,7 @@ rebuildTarget verbosity
     unexpectedState = error "rebuildTarget: unexpected package status"
 
     downloadPhase = do
-        downsrcloc <- annotateFailure (BuildFailure Nothing . DownloadFailed) $
+        downsrcloc <- annotateFailureNoLog DownloadFailed $
                         waitAsyncPackageDownload verbosity downloadMap pkg
         case downsrcloc of
           DownloadedTarball tarball -> unpackTarballPhase tarball
@@ -888,7 +888,7 @@ unpackPackageTarball :: Verbosity -> FilePath -> FilePath
                      -> IO ()
 unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
     --TODO: [nice to have] switch to tar package and catch tar exceptions
-    annotateFailure (BuildFailure Nothing . UnpackFailed) $ do
+    annotateFailureNoLog UnpackFailed $ do
 
       -- Unpack the tarball
       --
@@ -977,18 +977,18 @@ buildAndInstallUnpackedPackage verbosity
     -- Configure phase
     when isParallelBuild $
       notice verbosity $ "Configuring " ++ display pkgid ++ "..."
-    annotateFailure (BuildFailure mlogFile . ConfigureFailed) $
+    annotateFailure mlogFile ConfigureFailed $
       setup configureCommand configureFlags
 
     -- Build phase
     when isParallelBuild $
       notice verbosity $ "Building " ++ display pkgid ++ "..."
-    annotateFailure (BuildFailure mlogFile . BuildFailed) $
+    annotateFailure mlogFile BuildFailed $
       setup buildCommand buildFlags
 
     -- Install phase
     ipkgs <-
-      annotateFailure (BuildFailure mlogFile . InstallFailed) $ do
+      annotateFailure mlogFile InstallFailed $ do
       --TODO: [required eventually] need to lock installing this ipkig so other processes don't
       -- stomp on our files, since we don't have ABI compat, not safe to replace
 
@@ -1138,7 +1138,7 @@ buildInplaceUnpackedPackage verbosity
         -- Configure phase
         --
         whenReConfigure $ do
-          annotateFailure (BuildFailure Nothing . ConfigureFailed) $
+          annotateFailureNoLog ConfigureFailed $
             setup configureCommand configureFlags []
           invalidatePackageRegFileMonitor packageFileMonitor
           updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
@@ -1153,7 +1153,7 @@ buildInplaceUnpackedPackage verbosity
 
         whenRebuild $ do
           timestamp <- beginUpdateFileMonitor
-          annotateFailure (BuildFailure Nothing . BuildFailed) $
+          annotateFailureNoLog BuildFailed $
             setup buildCommand buildFlags buildArgs
 
           --TODO: [required eventually] this doesn't track file
@@ -1166,7 +1166,7 @@ buildInplaceUnpackedPackage verbosity
                                         allSrcFiles buildResult
 
         ipkgs <- whenReRegister $
-                 annotateFailure (BuildFailure Nothing . InstallFailed) $ do
+                 annotateFailureNoLog InstallFailed $ do
           -- Register locally
           ipkgs <- if pkgRequiresRegistration pkg
             then do
@@ -1241,12 +1241,12 @@ buildInplaceUnpackedPackage verbosity
         -- Repl phase
         --
         whenRepl $
-          annotateFailure (BuildFailure Nothing . ReplFailed) $
+          annotateFailureNoLog ReplFailed $
           setup replCommand replFlags replArgs
 
         -- Haddock phase
         whenHaddock $
-          annotateFailure (BuildFailure Nothing . HaddocksFailed) $
+          annotateFailureNoLog HaddocksFailed $
           setup haddockCommand haddockFlags []
 
         return BuildResult {
@@ -1327,8 +1327,15 @@ buildInplaceUnpackedPackage verbosity
 
 
 -- helper
-annotateFailure :: (SomeException -> BuildFailure) -> IO a -> IO a
-annotateFailure annotate action =
+annotateFailureNoLog :: (SomeException -> BuildFailureReason)
+                     -> IO a -> IO a
+annotateFailureNoLog annotate action =
+  annotateFailure Nothing annotate action
+
+annotateFailure :: Maybe FilePath
+                -> (SomeException -> BuildFailureReason)
+                -> IO a -> IO a
+annotateFailure mlogFile annotate action =
   action `catches`
     -- It's not just IOException and ExitCode we have to deal with, there's
     -- lots, including exceptions from the hackage-security and tar packages.
@@ -1343,7 +1350,7 @@ annotateFailure annotate action =
     ]
   where
     handler :: Exception e => e -> IO a
-    handler = throwIO . annotate . toException
+    handler = throwIO . BuildFailure mlogFile . annotate . toException
 
 
 withTempInstalledPackageInfoFiles :: Verbosity -> FilePath