Commit cdacc518 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

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.
parent b799346d
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
{-# 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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment