From cdacc518807e479855abc4981c1871a8fc651cec Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 26 Jul 2016 18:28:36 +0100 Subject: [PATCH] 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. --- .../Distribution/Client/ProjectBuilding.hs | 66 ++++++++++--------- .../Client/ProjectOrchestration.hs | 4 +- .../Distribution/Client/ProjectPlanning.hs | 12 ---- .../Client/ProjectPlanning/Types.hs | 56 ---------------- cabal-install/Distribution/Client/Types.hs | 11 +++- 5 files changed, 45 insertions(+), 104 deletions(-) diff --git a/cabal-install/Distribution/Client/ProjectBuilding.hs b/cabal-install/Distribution/Client/ProjectBuilding.hs index bbeb7385d26..f0e36774dcf 100644 --- a/cabal-install/Distribution/Client/ProjectBuilding.hs +++ b/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,7 +1281,7 @@ 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) @@ -1278,12 +1289,7 @@ annotateFailure annotate action = ] 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 diff --git a/cabal-install/Distribution/Client/ProjectOrchestration.hs b/cabal-install/Distribution/Client/ProjectOrchestration.hs index 924ee0d6442..6b332102c7b 100644 --- a/cabal-install/Distribution/Client/ProjectOrchestration.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 55530e42f26..aea11ebea94 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/Distribution/Client/ProjectPlanning/Types.hs index 0d18e565ae5..2eb617a8f22 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning/Types.hs +++ b/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 diff --git a/cabal-install/Distribution/Client/Types.hs b/cabal-install/Distribution/Client/Types.hs index c3362e39011..ed05daa826f 100644 --- a/cabal-install/Distribution/Client/Types.hs +++ b/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)