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)