Convert new-build to use the common BuildSuccess/Failure types

As a result of the previous InstallPlan refactoring, we can now use the
non-serialisable BuildFailure type from D.C.Types which uses
SomeException, where previously we had to use a copy of that type that
used String for the errors.

So now there's no longer any need to have a separate set of types for
BuildResult, BuildResults, BuildSuccess or BuildFailure. There was a
minor difference in the structure of the BuildSuccess, where in the new
build code we need to be able to produce the InstalledPackageInfo at a
different point from the rest of the info in the BuildSuccess. This can
be kept local to the ProjecBuilding module, but accounts for the
somewhat larger number of changes in that module.

cabal-install/Distribution/Client/ProjectBuilding.hs

@@ -5,12 +5,19 @@
 -- | 
 --
 module Distribution.Client.ProjectBuilding (
+    -- * Dry run phase
     BuildStatus(..),
     BuildStatusMap,
     BuildStatusRebuild(..),
     BuildReason(..),
     MonitorChangedReason(..),
     rebuildTargetsDryRun,
+
+    -- * Build phase
+    BuildResult,
+    BuildResults,
+    BuildFailure(..),
+    BuildSuccess(..),
     rebuildTargets
   ) where
 
@@ -20,8 +27,6 @@ import           Distribution.Client.ProjectConfig
 import           Distribution.Client.ProjectPlanning
 
 import           Distribution.Client.Types
-                   ( PackageLocation(..), GenericReadyPackage(..)
-                   , InstalledPackageId, installedPackageId )
 import           Distribution.Client.InstallPlan
                    ( GenericInstallPlan, GenericPlanPackage )
 import qualified Distribution.Client.InstallPlan as InstallPlan
@@ -152,7 +157,7 @@ data BuildStatus =
      -- | The package exists in a local dir already, and is fully up to date.
      --   So this package can be put into the 'InstallPlan.Installed' state
      --   and it does not need to be built.
-   | BuildStatusUpToDate [InstalledPackageInfo] BuildSuccess
+   | BuildStatusUpToDate BuildSuccess
 
 -- | For a package that is going to be built or rebuilt, the state it's in now.
 --
@@ -293,8 +298,8 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} = \installPlan -> do
             return (BuildStatusRebuild srcdir rebuild)
 
           -- No changes, the package is up to date. Use the saved build results.
-          Right (ipkgs, buildSuccess) ->
-            return (BuildStatusUpToDate ipkgs buildSuccess)
+          Right buildSuccess ->
+            return (BuildStatusUpToDate buildSuccess)
       where
         packageFileMonitor =
           newPackageFileMonitor distDirLayout (packageId pkg)
@@ -346,7 +351,7 @@ improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
           <- InstallPlan.reverseTopologicalOrder installPlan
       , let ipkgid = installedPackageId pkg
             Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus
-      , BuildStatusUpToDate ipkgs _buildSuccess <- [pkgBuildStatus]
+      , BuildStatusUpToDate (BuildOk _ _ ipkgs) <- [pkgBuildStatus]
       ]
   where
     replaceWithPrePreExisting =
@@ -374,10 +379,18 @@ improveInstallPlanWithUpToDatePackages installPlan pkgsBuildStatus =
 --
 data PackageFileMonitor = PackageFileMonitor {
        pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),
-       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildSuccess,
+       pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildSuccessMisc,
        pkgFileMonitorReg    :: FileMonitor () [InstalledPackageInfo]
      }
 
+-- | This is all the components of the 'BuildSuccess' other than the
+-- @['InstalledPackageInfo']@.
+--
+-- We have to split up the 'BuildSuccess' components since they get produced
+-- at different times (or rather, when different things change).
+--
+type BuildSuccessMisc = (DocsResult, TestsResult)
+
 newPackageFileMonitor :: DistDirLayout -> PackageId -> PackageFileMonitor
 newPackageFileMonitor DistDirLayout{distPackageCacheFile} pkgid =
     PackageFileMonitor {
@@ -433,9 +446,7 @@ checkPackageFileMonitorChanged :: PackageFileMonitor
                                -> ElaboratedConfiguredPackage
                                -> FilePath
                                -> ComponentDeps [BuildStatus]
-                               -> IO (Either BuildStatusRebuild
-                                            ([InstalledPackageInfo],
-                                             BuildSuccess))
+                               -> IO (Either BuildStatusRebuild BuildSuccess)
 checkPackageFileMonitorChanged PackageFileMonitor{..}
                                pkg srcdir depsBuildStatus = do
     --TODO: [nice to have] some debug-level message about file changes, like rerunIfChanged
@@ -490,7 +501,9 @@ checkPackageFileMonitorChanged PackageFileMonitor{..}
                   buildReason = BuildReasonEphemeralTargets
 
               (MonitorUnchanged buildSuccess _, MonitorUnchanged ipkgs _) ->
-                return (Right (ipkgs, buildSuccess))
+                  return (Right (BuildOk docsResult testsResult ipkgs))
+                where
+                  (docsResult, testsResult) = buildSuccess
   where
     (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
     changedToMaybe (MonitorChanged     _) = Nothing
@@ -514,7 +527,7 @@ updatePackageBuildFileMonitor :: PackageFileMonitor
                               -> ElaboratedConfiguredPackage
                               -> BuildStatusRebuild
                               -> [FilePath]
-                              -> BuildSuccess
+                              -> BuildSuccessMisc
                               -> IO ()
 updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
                               srcdir timestamp pkg pkgBuildStatus
@@ -602,9 +615,7 @@ rebuildTargets verbosity
       -- For each package in the plan, in dependency order, but in parallel...
       InstallPlan.execute jobControl keepGoing (DependentFailed . packageId)
                           installPlan $ \pkg ->
-        fmap (\x -> case x of BuildFailure f   -> Left f
-                              BuildSuccess _ s -> Right s) $
-        handle (return . BuildFailure) $ --TODO: review exception handling
+        handle (return . Left) $ fmap Right $ --TODO: review exception handling
 
         let ipkgid = installedPackageId pkg
             Just pkgBuildStatus = Map.lookup ipkgid pkgsBuildStatus in
@@ -641,7 +652,7 @@ rebuildTarget :: Verbosity
               -> ElaboratedSharedConfig
               -> ElaboratedReadyPackage
               -> BuildStatus
-              -> IO BuildResult
+              -> IO BuildSuccess
 rebuildTarget verbosity
               distDirLayout@DistDirLayout{distBuildDirectory}
               buildSettings downloadMap
@@ -900,7 +911,7 @@ buildAndInstallUnpackedPackage :: Verbosity
                                -> ElaboratedSharedConfig
                                -> ElaboratedReadyPackage
                                -> FilePath -> FilePath
-                               -> IO BuildResult
+                               -> IO BuildSuccess
 buildAndInstallUnpackedPackage verbosity
                                DistDirLayout{distTempDirectory}
                                BuildTimeSettings {
@@ -942,7 +953,7 @@ buildAndInstallUnpackedPackage verbosity
       setup buildCommand buildFlags
 
     -- Install phase
-    mipkg <-
+    ipkgs <-
       annotateFailure 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
@@ -997,7 +1008,7 @@ buildAndInstallUnpackedPackage verbosity
     let docsResult  = DocsNotTried
         testsResult = TestsNotTried
 
-    return (BuildSuccess mipkg (BuildOk docsResult testsResult))
+    return (BuildOk docsResult testsResult ipkgs)
 
   where
     pkgid  = packageId rpkg
@@ -1063,7 +1074,7 @@ buildInplaceUnpackedPackage :: Verbosity
                             -> ElaboratedReadyPackage
                             -> BuildStatusRebuild
                             -> FilePath -> FilePath
-                            -> IO BuildResult
+                            -> IO BuildSuccess
 buildInplaceUnpackedPackage verbosity
                             distDirLayout@DistDirLayout {
                               distTempDirectory,
@@ -1097,8 +1108,8 @@ buildInplaceUnpackedPackage verbosity
         let docsResult  = DocsNotTried
             testsResult = TestsNotTried
 
-            buildSuccess :: BuildSuccess
-            buildSuccess = BuildOk docsResult testsResult
+            buildSuccess :: BuildSuccessMisc
+            buildSuccess = (docsResult, testsResult)
 
         whenRebuild $ do
           timestamp <- beginUpdateFileMonitor
@@ -1197,7 +1208,7 @@ buildInplaceUnpackedPackage verbosity
           annotateFailure BuildFailed $
           setup haddockCommand haddockFlags []
 
-        return (BuildSuccess ipkgs buildSuccess)
+        return (BuildOk docsResult testsResult ipkgs)
 
   where
     pkgid  = packageId rpkg
@@ -1270,20 +1281,15 @@ buildInplaceUnpackedPackage verbosity
 
 
 -- helper
-annotateFailure :: (String -> BuildFailure) -> IO a -> IO a
+annotateFailure :: (SomeException -> BuildFailure) -> IO a -> IO a
 annotateFailure annotate action =
   action `catches`
     [ Handler $ \ioe  -> handler (ioe  :: IOException)
     , Handler $ \exit -> handler (exit :: ExitCode)
     ]
   where
     handler :: Exception e => e -> IO a
-    handler = throwIO . annotate
-#if MIN_VERSION_base(4,8,0)
-            . displayException
-#else
-            . show
-#endif
+    handler = throwIO . annotate . toException
 
 
 withTempInstalledPackageInfoFiles :: Verbosity -> FilePath

cabal-install/Distribution/Client/ProjectOrchestration.hs

@@ -60,8 +60,6 @@ import           Distribution.Client.ProjectPlanning
 import           Distribution.Client.ProjectBuilding
 
 import           Distribution.Client.Types
-                   hiding ( BuildResult, BuildResults, BuildSuccess(..)
-                          , BuildFailure(..), DocsResult(..), TestsResult(..) )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import           Distribution.Client.BuildTarget
                    ( UserBuildTarget, resolveUserBuildTargets
@@ -208,7 +206,7 @@ runProjectBuildPhase verbosity ProjectBuildContext {..} =
     previousBuildResults :: BuildStatusMap -> BuildResults
     previousBuildResults =
       Map.mapMaybe $ \status -> case status of
-        BuildStatusUpToDate _ buildSuccess -> Just (Right buildSuccess)
+        BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)
         --TODO: [nice to have] record build failures persistently
         _                                  -> Nothing
 

cabal-install/Distribution/Client/ProjectPlanning.hs

@@ -12,16 +12,6 @@ module Distribution.Client.ProjectPlanning (
     BuildStyle(..),
     CabalFileText,
 
-    --TODO: [code cleanup] these types should live with execution, not with
-    --      plan definition. Need to better separate InstallPlan definition.
-    GenericBuildResult(..),
-    BuildResult,
-    BuildResults,
-    BuildSuccess(..),
-    BuildFailure(..),
-    DocsResult(..),
-    TestsResult(..),
-
     -- * Producing the elaborated install plan
     rebuildInstallPlan,
 
@@ -62,8 +52,6 @@ import           Distribution.Client.ProjectConfig
 import           Distribution.Client.ProjectPlanOutput
 
 import           Distribution.Client.Types
-                   hiding ( BuildResult, BuildResults, BuildSuccess(..)
-                          , BuildFailure(..), DocsResult(..), TestsResult(..) )
 import qualified Distribution.Client.InstallPlan as InstallPlan
 import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
 import           Distribution.Client.Dependency

cabal-install/Distribution/Client/ProjectPlanning/Types.hs

@@ -16,17 +16,6 @@ module Distribution.Client.ProjectPlanning.Types (
     BuildStyle(..),
     CabalFileText,
 
-    -- * Types used in executing an install plan
-    --TODO: [code cleanup] these types should live with execution, not with
-    --      plan definition. Need to better separate InstallPlan definition.
-    GenericBuildResult(..),
-    BuildResult,
-    BuildResults,
-    BuildSuccess(..),
-    BuildFailure(..),
-    DocsResult(..),
-    TestsResult(..),
-
     -- * Build targets
     PackageTarget(..),
     ComponentTarget(..),
@@ -68,8 +57,6 @@ import           Data.Set (Set)
 import qualified Data.ByteString.Lazy as LBS
 import           Distribution.Compat.Binary
 import           GHC.Generics (Generic)
-import           Data.Typeable (Typeable)
-import           Control.Exception
 
 
 
@@ -280,49 +267,6 @@ type CabalFileText = LBS.ByteString
 
 type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage
 
---TODO: [code cleanup] this duplicates the InstalledPackageInfo quite a bit in an install plan
--- because the same ipkg is used by many packages. So the binary file will be big.
--- Could we keep just (ipkgid, deps) instead of the whole InstalledPackageInfo?
--- or transform to a shared form when serialising / deserialising
-
-data GenericBuildResult ipkg iresult ifailure
-                  = BuildFailure ifailure
-                  | BuildSuccess [ipkg] iresult
-  deriving (Eq, Show, Generic)
-
-instance (Binary ipkg, Binary iresult, Binary ifailure) =>
-         Binary (GenericBuildResult ipkg iresult ifailure)
-
-type BuildResult  = GenericBuildResult InstalledPackageInfo
-                                       BuildSuccess BuildFailure
-type BuildResults = Map UnitId (Either BuildFailure BuildSuccess)
-
-data BuildSuccess = BuildOk DocsResult TestsResult
-  deriving (Eq, Show, Generic)
-
-data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk
-  deriving (Eq, Show, Generic)
-
-data TestsResult = TestsNotTried | TestsOk
-  deriving (Eq, Show, Generic)
-
-data BuildFailure = PlanningFailed              --TODO: [required eventually] not yet used
-                  | DependentFailed PackageId
-                  | DownloadFailed  String      --TODO: [required eventually] not yet used
-                  | UnpackFailed    String      --TODO: [required eventually] not yet used
-                  | ConfigureFailed String
-                  | BuildFailed     String
-                  | TestsFailed     String      --TODO: [required eventually] not yet used
-                  | InstallFailed   String
-  deriving (Eq, Show, Typeable, Generic)
-
-instance Exception BuildFailure
-
-instance Binary BuildFailure
-instance Binary BuildSuccess
-instance Binary DocsResult
-instance Binary TestsResult
-
 
 ---------------------------
 -- Build targets

cabal-install/Distribution/Client/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
@@ -39,7 +40,8 @@ import Distribution.Solver.Types.SourcePackage
 import Data.Map (Map)
 import Network.URI (URI(..), URIAuth(..), nullURI)
 import Control.Exception
-         ( SomeException )
+         ( Exception, SomeException )
+import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Distribution.Compat.Binary (Binary(..))
 
@@ -266,7 +268,7 @@ maybeRepoRemote (RepoSecure r _localDir) = Just r
 -- ------------------------------------------------------------
 
 type BuildResult  = Either BuildFailure BuildSuccess
-type BuildResults = Map UnitId (Either BuildFailure BuildSuccess)
+type BuildResults = Map UnitId BuildResult
 
 data BuildFailure = PlanningFailed
                   | DependentFailed PackageId
@@ -276,7 +278,10 @@ data BuildFailure = PlanningFailed
                   | BuildFailed     SomeException
                   | TestsFailed     SomeException
                   | InstallFailed   SomeException
-  deriving (Show, Generic)
+  deriving (Show, Typeable, Generic)
+
+instance Exception BuildFailure
+
 data BuildSuccess = BuildOk         DocsResult TestsResult
                                     [InstalledPackageInfo]
   deriving (Show, Generic)