From f70fc980dca50e7e62c5e803f56d2ef0c9fc7e18 Mon Sep 17 00:00:00 2001
From: Rodrigo Mesquita <rodrigo.m.mesquita@gmail.com>
Date: Fri, 15 Dec 2023 12:21:04 +0000
Subject: [PATCH] Refactor ProjectBuilding into Package Phases
This refactor of Distribution.Client.ProjectBuilding does the following:
* Moves package file monitoring logic to
Distribution.Client.ProjectBuilding.PackageFileMonitor
* Moves the `buildInplaceUnpackedPackage` and
`buildAndInstallUnpackedPackage` with auxiliary functions to
Distribution.Client.ProjectBuilding.UnpackedPackage
* Refactors the common bits of `buildInplaceUnpackedPackage` and
`buildAndInstallUnpackedPackage` to remove considerable code
duplication while simplifying and making both functions more
structured.
Namely, to better structure build inplace vs build and install, I've
introduced:
* `PackageBuildingPhase` describes the various phases of processing the
unpacked package both inplace and on install
* Configure
* Build
* Install (copy + register)
* Test
* Bench
* Repl
* Haddock
* Then, `buildAndRegisterUnpackedPackage` implements the common logic
between the two functions (such as calls to ./Setup and the order of
the phases) but delegates the logic specific to each phase to an
argument function which maps `PackageBuildingPhase` to `IO` actions.
* Now, build inplace and build and install functions are comprised as:
* A wrapper around `buildAndRegisterUnpackedPackage` which does
things specific to each before and after the main phases are
processed
* A delegate function which maps an action to each package
processing phase
Fixes #9499
---
cabal-install/cabal-install.cabal | 2 +
.../Distribution/Client/ProjectBuilding.hs | 1068 +----------------
.../ProjectBuilding/PackageFileMonitor.hs | 294 +++++
.../Client/ProjectBuilding/UnpackedPackage.hs | 921 ++++++++++++++
4 files changed, 1224 insertions(+), 1061 deletions(-)
create mode 100644 cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
create mode 100644 cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal
index 2ef1929e6a..373152e8f6 100644
--- a/cabal-install/cabal-install.cabal
+++ b/cabal-install/cabal-install.cabal
@@ -154,6 +154,8 @@ library
Distribution.Client.PackageHash
Distribution.Client.ParseUtils
Distribution.Client.ProjectBuilding
+ Distribution.Client.ProjectBuilding.UnpackedPackage
+ Distribution.Client.ProjectBuilding.PackageFileMonitor
Distribution.Client.ProjectBuilding.Types
Distribution.Client.ProjectConfig
Distribution.Client.ProjectConfig.Legacy
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index 84ae5da18e..a0906686dd 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -44,18 +44,15 @@ module Distribution.Client.ProjectBuilding
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.PackageHash (renderPackageHashInputs)
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
-import Distribution.Client.RebuildMonad
import Distribution.Client.Store
import Distribution.Client.DistDirLayout
import Distribution.Client.FetchUtils
-import Distribution.Client.FileMonitor
import Distribution.Client.GlobalFlags (RepoContext)
import Distribution.Client.InstallPlan
( GenericInstallPlan
@@ -64,15 +61,6 @@ import Distribution.Client.InstallPlan
)
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.JobControl
-import Distribution.Client.Setup
- ( filterConfigureFlags
- , filterHaddockArgs
- , filterHaddockFlags
- , filterTestFlags
- )
-import Distribution.Client.SetupWrapper
-import Distribution.Client.SourceFiles
-import Distribution.Client.SrcDist (allPackageSourceFiles)
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types hiding
( BuildFailure (..)
@@ -80,61 +68,37 @@ import Distribution.Client.Types hiding
, BuildOutcomes
, BuildResult (..)
)
-import Distribution.Client.Utils
- ( ProgressPhase (..)
- , findOpenProgramLocation
- , numberOfProcessors
- , progressMessage
- , removeExistingFile
- )
-import Distribution.Compat.Lens
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.Package
-import qualified Distribution.PackageDescription as PD
-import Distribution.Simple.BuildPaths (haddockDirName)
-import Distribution.Simple.Command (CommandUI)
import Distribution.Simple.Compiler
( Compiler
, PackageDB (..)
- , compilerId
, jsemSupported
)
-import qualified Distribution.Simple.InstallDirs as InstallDirs
-import Distribution.Simple.LocalBuildInfo
- ( ComponentName (..)
- , LibraryName (..)
- )
import Distribution.Simple.Program
import qualified Distribution.Simple.Register as Cabal
-import qualified Distribution.Simple.Setup as Cabal
-import Distribution.Types.BuildType
-import Distribution.Types.PackageDescription.Lens (componentModules)
import Distribution.Compat.Graph (IsNode (..))
import Distribution.Simple.Utils
import Distribution.Version
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
-import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Text.PrettyPrint as Disp
-import Control.Exception (Handler (..), SomeAsyncException, assert, bracket, catches, handle)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
-import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
-import System.IO (Handle, IOMode (AppendMode), withFile)
+import Control.Exception (assert, bracket, handle)
+import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
+import System.FilePath (makeRelative, takeDirectory, (<.>), (</>))
import System.Semaphore (SemaphoreName (..))
import Distribution.Client.Errors
-import Distribution.Compat.Directory (listDirectory)
import Distribution.Simple.Flag (fromFlagOrDefault)
+import Distribution.Client.ProjectBuilding.PackageFileMonitor
+import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
+import Distribution.Client.Utils (numberOfProcessors)
+
------------------------------------------------------------------------------
-- * Overall building strategy.
@@ -344,271 +308,6 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
++ prettyShow (packageId pkg)
++ " not in status map"
------------------------------
--- Package change detection
---
-
--- | As part of the dry run for local unpacked packages we have to check if the
--- package config or files have changed. That is the purpose of
--- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.
---
--- When a package is (re)built, the monitor must be updated to reflect the new
--- state of the package. Because we sometimes build without reconfiguring the
--- state updates are split into two, one for package config changes and one
--- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'
--- and 'updatePackageBuildFileMonitor'.
-data PackageFileMonitor = PackageFileMonitor
- { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage ()
- , pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc
- , pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
- }
-
--- | This is all the components of the 'BuildResult' other than the
--- @['InstalledPackageInfo']@.
---
--- We have to split up the 'BuildResult' components since they get produced
--- at different times (or rather, when different things change).
-type BuildResultMisc = (DocsResult, TestsResult)
-
-newPackageFileMonitor
- :: ElaboratedSharedConfig
- -> DistDirLayout
- -> DistDirParams
- -> PackageFileMonitor
-newPackageFileMonitor
- shared
- DistDirLayout{distPackageCacheFile}
- dparams =
- PackageFileMonitor
- { pkgFileMonitorConfig =
- FileMonitor
- { fileMonitorCacheFile = distPackageCacheFile dparams "config"
- , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared
- , fileMonitorCheckIfOnlyValueChanged = False
- }
- , pkgFileMonitorBuild =
- FileMonitor
- { fileMonitorCacheFile = distPackageCacheFile dparams "build"
- , fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt ->
- componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt
- , fileMonitorCheckIfOnlyValueChanged = True
- }
- , pkgFileMonitorReg =
- newFileMonitor (distPackageCacheFile dparams "registration")
- }
-
--- | Helper function for 'checkPackageFileMonitorChanged',
--- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.
---
--- It selects the info from a 'ElaboratedConfiguredPackage' that are used by
--- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.
-packageFileMonitorKeyValues
- :: ElaboratedConfiguredPackage
- -> (ElaboratedConfiguredPackage, Set ComponentName)
-packageFileMonitorKeyValues elab =
- (elab_config, buildComponents)
- where
- -- The first part is the value used to guard (re)configuring the package.
- -- That is, if this value changes then we will reconfigure.
- -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of
- -- information that affects the (re)configure step. But those parts that
- -- do not affect the configure step need to be nulled out. Those parts are
- -- the specific targets that we're going to build.
- --
-
- -- Additionally we null out the parts that don't affect the configure step because they're simply
- -- about how tests or benchmarks are run
-
- -- TODO there may be more things to null here too, in the future.
-
- elab_config :: ElaboratedConfiguredPackage
- elab_config =
- elab
- { elabBuildTargets = []
- , elabTestTargets = []
- , elabBenchTargets = []
- , elabReplTarget = []
- , elabHaddockTargets = []
- , elabBuildHaddocks = False
- , elabTestMachineLog = Nothing
- , elabTestHumanLog = Nothing
- , elabTestShowDetails = Nothing
- , elabTestKeepTix = False
- , elabTestTestOptions = []
- , elabBenchmarkOptions = []
- }
-
- -- The second part is the value used to guard the build step. So this is
- -- more or less the opposite of the first part, as it's just the info about
- -- what targets we're going to build.
- --
- buildComponents :: Set ComponentName
- buildComponents = elabBuildTargetWholeComponents elab
-
--- | Do all the checks on whether a package has changed and thus needs either
--- rebuilding or reconfiguring and rebuilding.
-checkPackageFileMonitorChanged
- :: PackageFileMonitor
- -> ElaboratedConfiguredPackage
- -> FilePath
- -> [BuildStatus]
- -> IO (Either BuildStatusRebuild BuildResult)
-checkPackageFileMonitorChanged
- PackageFileMonitor{..}
- pkg
- srcdir
- depsBuildStatus = do
- -- TODO: [nice to have] some debug-level message about file
- -- changes, like rerunIfChanged
- configChanged <-
- checkFileMonitorChanged
- pkgFileMonitorConfig
- srcdir
- pkgconfig
- case configChanged of
- MonitorChanged monitorReason ->
- return (Left (BuildStatusConfigure monitorReason'))
- where
- monitorReason' = fmap (const ()) monitorReason
- MonitorUnchanged () _
- -- The configChanged here includes the identity of the dependencies,
- -- so depsBuildStatus is just needed for the changes in the content
- -- of dependencies.
- | any buildStatusRequiresBuild depsBuildStatus -> do
- regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
- let mreg = changedToMaybe regChanged
- return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))
- | otherwise -> do
- buildChanged <-
- checkFileMonitorChanged
- pkgFileMonitorBuild
- srcdir
- buildComponents
- regChanged <-
- checkFileMonitorChanged
- pkgFileMonitorReg
- srcdir
- ()
- let mreg = changedToMaybe regChanged
- case (buildChanged, regChanged) of
- (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->
- return (Left (BuildStatusBuild mreg buildReason))
- where
- buildReason = BuildReasonExtraTargets prevBuildComponents
- (MonitorChanged monitorReason, _) ->
- return (Left (BuildStatusBuild mreg buildReason))
- where
- buildReason = BuildReasonFilesChanged monitorReason'
- monitorReason' = fmap (const ()) monitorReason
- (MonitorUnchanged _ _, MonitorChanged monitorReason) ->
- -- this should only happen if the file is corrupt or been
- -- manually deleted. We don't want to bother with another
- -- phase just for this, so we'll reregister by doing a build.
- return (Left (BuildStatusBuild Nothing buildReason))
- where
- buildReason = BuildReasonFilesChanged monitorReason'
- monitorReason' = fmap (const ()) monitorReason
- (MonitorUnchanged _ _, MonitorUnchanged _ _)
- | pkgHasEphemeralBuildTargets pkg ->
- return (Left (BuildStatusBuild mreg buildReason))
- where
- buildReason = BuildReasonEphemeralTargets
- (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->
- return $
- Right
- BuildResult
- { buildResultDocs = docsResult
- , buildResultTests = testsResult
- , buildResultLogFile = Nothing
- }
- where
- (docsResult, testsResult) = buildResult
- where
- (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
- changedToMaybe :: MonitorChanged a b -> Maybe b
- changedToMaybe (MonitorChanged _) = Nothing
- changedToMaybe (MonitorUnchanged x _) = Just x
-
-updatePackageConfigFileMonitor
- :: PackageFileMonitor
- -> FilePath
- -> ElaboratedConfiguredPackage
- -> IO ()
-updatePackageConfigFileMonitor
- PackageFileMonitor{pkgFileMonitorConfig}
- srcdir
- pkg =
- updateFileMonitor
- pkgFileMonitorConfig
- srcdir
- Nothing
- []
- pkgconfig
- ()
- where
- (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg
-
-updatePackageBuildFileMonitor
- :: PackageFileMonitor
- -> FilePath
- -> MonitorTimestamp
- -> ElaboratedConfiguredPackage
- -> BuildStatusRebuild
- -> [MonitorFilePath]
- -> BuildResultMisc
- -> IO ()
-updatePackageBuildFileMonitor
- PackageFileMonitor{pkgFileMonitorBuild}
- srcdir
- timestamp
- pkg
- pkgBuildStatus
- monitors
- buildResult =
- updateFileMonitor
- pkgFileMonitorBuild
- srcdir
- (Just timestamp)
- monitors
- buildComponents'
- buildResult
- where
- (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
-
- -- If the only thing that's changed is that we're now building extra
- -- components, then we can avoid later unnecessary rebuilds by saving the
- -- total set of components that have been built, namely the union of the
- -- existing ones plus the new ones. If files also changed this would be
- -- the wrong thing to do. Note that we rely on the
- -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
- -- that it's /only/ the value that changed not any files that changed.
- buildComponents' =
- case pkgBuildStatus of
- BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) ->
- buildComponents `Set.union` prevBuildComponents
- _ -> buildComponents
-
-updatePackageRegFileMonitor
- :: PackageFileMonitor
- -> FilePath
- -> Maybe InstalledPackageInfo
- -> IO ()
-updatePackageRegFileMonitor
- PackageFileMonitor{pkgFileMonitorReg}
- srcdir
- mipkg =
- updateFileMonitor
- pkgFileMonitorReg
- srcdir
- Nothing
- []
- ()
- mipkg
-
-invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
-invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
- removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
-
------------------------------------------------------------------------------
-- * Doing it: executing an 'ElaboratedInstallPlan'
@@ -1135,756 +834,3 @@ moveTarballShippedDistDirectory
where
tarballDistDir = parentdir </> prettyShow pkgid </> "dist"
targetDistDir = distBuildDirectory dparams
-
-buildAndInstallUnpackedPackage
- :: Verbosity
- -> DistDirLayout
- -> StoreDirLayout
- -> Maybe SemaphoreName
- -- ^ Whether to pass a semaphore to build process
- -- this is different to BuildTimeSettings because the
- -- name of the semaphore is created freshly each time.
- -> BuildTimeSettings
- -> Lock
- -> Lock
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> ElaboratedReadyPackage
- -> FilePath
- -> FilePath
- -> IO BuildResult
-buildAndInstallUnpackedPackage
- verbosity
- distDirLayout@DistDirLayout{distTempDirectory}
- storeDirLayout@StoreDirLayout
- { storePackageDBStack
- }
- maybe_semaphore
- BuildTimeSettings
- { buildSettingNumJobs
- , buildSettingLogFile
- }
- registerLock
- cacheLock
- pkgshared@ElaboratedSharedConfig
- { pkgConfigPlatform = platform
- , pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = progdb
- }
- plan
- rpkg@(ReadyPackage pkg)
- srcdir
- builddir = do
- createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)
- initLogFile
-
- -- TODO: [code cleanup] deal consistently with talking to older
- -- Setup.hs versions, much like we do for ghc, with a proper
- -- options type and rendering step which will also let us
- -- call directly into the lib, rather than always going via
- -- the lib's command line interface, which would also allow
- -- passing data like installed packages, compiler, and
- -- program db for a quicker configure.
-
- -- TODO: [required feature] docs and tests
- -- TODO: [required feature] sudo re-exec
-
- -- Configure phase
- noticeProgress ProgressStarting
-
- annotateFailure mlogFile ConfigureFailed $
- setup' configureCommand configureFlags configureArgs
-
- -- Build phase
- noticeProgress ProgressBuilding
-
- annotateFailure mlogFile BuildFailed $
- setup buildCommand buildFlags
-
- -- Haddock phase
- whenHaddock $ do
- noticeProgress ProgressHaddock
- annotateFailureNoLog HaddocksFailed $
- setup haddockCommand haddockFlags
-
- -- Install phase
- noticeProgress ProgressInstalling
- annotateFailure mlogFile InstallFailed $ do
- let copyPkgFiles tmpDir = do
- let tmpDirNormalised = normalise tmpDir
- setup Cabal.copyCommand (copyFlags tmpDirNormalised)
- -- Note that the copy command has put the files into
- -- @$tmpDir/$prefix@ so we need to return this dir so
- -- the store knows which dir will be the final store entry.
- let prefix =
- normalise $
- dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
- entryDir = tmpDirNormalised </> prefix
-
- -- if there weren't anything to build, it might be that directory is not created
- -- the @setup Cabal.copyCommand@ above might do nothing.
- -- https://github.com/haskell/cabal/issues/4130
- createDirectoryIfMissingVerbose verbosity True entryDir
-
- let hashFileName = entryDir </> "cabal-hash.txt"
- outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg)
-
- info verbosity $
- "creating file with the inputs used to compute the package hash: " ++ hashFileName
-
- LBS.writeFile hashFileName outPkgHashInputs
-
- debug verbosity "Package hash inputs:"
- traverse_
- (debug verbosity . ("> " ++))
- (lines $ LBS.Char8.unpack outPkgHashInputs)
-
- -- Ensure that there are no files in `tmpDir`, that are
- -- not in `entryDir`. While this breaks the
- -- prefix-relocatable property of the libraries, it is
- -- necessary on macOS to stay under the load command limit
- -- of the macOS mach-o linker. See also
- -- @PackageHash.hashedInstalledPackageIdVeryShort@.
- --
- -- We also normalise paths to ensure that there are no
- -- different representations for the same path. Like / and
- -- \\ on windows under msys.
- otherFiles <-
- filter (not . isPrefixOf entryDir)
- <$> listFilesRecursive tmpDirNormalised
- -- Here's where we could keep track of the installed files
- -- ourselves if we wanted to by making a manifest of the
- -- files in the tmp dir.
- return (entryDir, otherFiles)
- where
- listFilesRecursive :: FilePath -> IO [FilePath]
- listFilesRecursive path = do
- files <- fmap (path </>) <$> (listDirectory path)
- allFiles <- for files $ \file -> do
- isDir <- doesDirectoryExist file
- if isDir
- then listFilesRecursive file
- else return [file]
- return (concat allFiles)
-
- registerPkg
- | not (elabRequiresRegistration pkg) =
- debug verbosity $
- "registerPkg: elab does NOT require registration for "
- ++ prettyShow uid
- | otherwise = do
- -- We register ourselves rather than via Setup.hs. We need to
- -- grab and modify the InstalledPackageInfo. We decide what
- -- the installed package id is, not the build system.
- ipkg0 <- generateInstalledPackageInfo
- let ipkg = ipkg0{Installed.installedUnitId = uid}
- assert
- ( elabRegisterPackageDBStack pkg
- == storePackageDBStack compid
- )
- (return ())
- criticalSection registerLock $
- Cabal.registerPackage
- verbosity
- compiler
- progdb
- (storePackageDBStack compid)
- ipkg
- Cabal.defaultRegisterOptions
- { Cabal.registerMultiInstance = True
- , Cabal.registerSuppressFilesCheck = True
- }
-
- -- Actual installation
- void $
- newStoreEntry
- verbosity
- storeDirLayout
- compid
- uid
- copyPkgFiles
- registerPkg
-
- -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right
- -- thing. Although we do copy into an image dir and do the move into the
- -- final location ourselves, perhaps we ought to do some sanity checks on
- -- the image dir first.
-
- -- TODO: [required eventually] note that for nix-style
- -- installations it is not necessary to do the
- -- 'withWin32SelfUpgrade' dance, but it would be necessary for a
- -- shared bin dir.
-
- -- TODO: [required feature] docs and test phases
- let docsResult = DocsNotTried
- testsResult = TestsNotTried
-
- noticeProgress ProgressCompleted
-
- return
- BuildResult
- { buildResultDocs = docsResult
- , buildResultTests = testsResult
- , buildResultLogFile = mlogFile
- }
- where
- pkgid = packageId rpkg
- uid = installedUnitId rpkg
- compid = compilerId compiler
-
- dispname :: String
- dispname = case elabPkgOrComp pkg of
- ElabPackage _ ->
- prettyShow pkgid
- ++ " (all, legacy fallback)"
- ElabComponent comp ->
- prettyShow pkgid
- ++ " ("
- ++ maybe "custom" prettyShow (compComponentName comp)
- ++ ")"
-
- noticeProgress :: ProgressPhase -> IO ()
- noticeProgress phase =
- when (isParallelBuild buildSettingNumJobs) $
- progressMessage verbosity phase dispname
-
- whenHaddock action
- | hasValidHaddockTargets pkg = action
- | otherwise = return ()
-
- configureCommand = Cabal.configureCommand defaultProgramDb
- configureFlags v =
- flip filterConfigureFlags v $
- setupHsConfigureFlags
- plan
- rpkg
- pkgshared
- verbosity
- builddir
- configureArgs _ = setupHsConfigureArgs pkg
-
- buildCommand = Cabal.buildCommand defaultProgramDb
- comp_par_strat = case maybe_semaphore of
- Just sem_name -> Cabal.Flag (getSemaphoreName sem_name)
- _ -> Cabal.NoFlag
- buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir
-
- haddockCommand = Cabal.haddockCommand
- haddockFlags _ =
- setupHsHaddockFlags
- pkg
- pkgshared
- verbosity
- builddir
-
- generateInstalledPackageInfo :: IO InstalledPackageInfo
- generateInstalledPackageInfo =
- withTempInstalledPackageInfoFile
- verbosity
- distTempDirectory
- $ \pkgConfDest -> do
- let registerFlags _ =
- setupHsRegisterFlags
- pkg
- pkgshared
- verbosity
- builddir
- pkgConfDest
- setup Cabal.registerCommand registerFlags
-
- copyFlags destdir _ =
- setupHsCopyFlags
- pkg
- pkgshared
- verbosity
- builddir
- destdir
-
- scriptOptions =
- setupHsScriptOptions
- rpkg
- plan
- pkgshared
- distDirLayout
- srcdir
- builddir
- (isParallelBuild buildSettingNumJobs)
- cacheLock
-
- setup :: CommandUI flags -> (Version -> flags) -> IO ()
- setup cmd flags = setup' cmd flags (const [])
-
- setup'
- :: CommandUI flags
- -> (Version -> flags)
- -> (Version -> [String])
- -> IO ()
- setup' cmd flags args =
- withLogging $ \mLogFileHandle ->
- setupWrapper
- verbosity
- scriptOptions
- { useLoggingHandle = mLogFileHandle
- , useExtraEnvOverrides =
- dataDirsEnvironmentForPlan
- distDirLayout
- plan
- }
- (Just (elabPkgDescription pkg))
- cmd
- flags
- args
-
- mlogFile :: Maybe FilePath
- mlogFile =
- case buildSettingLogFile of
- Nothing -> Nothing
- Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
-
- initLogFile :: IO ()
- initLogFile =
- case mlogFile of
- Nothing -> return ()
- Just logFile -> do
- createDirectoryIfMissing True (takeDirectory logFile)
- exists <- doesFileExist logFile
- when exists $ removeFile logFile
-
- withLogging :: (Maybe Handle -> IO r) -> IO r
- withLogging action =
- case mlogFile of
- Nothing -> action Nothing
- Just logFile -> withFile logFile AppendMode (action . Just)
-
-hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
-hasValidHaddockTargets ElaboratedConfiguredPackage{..}
- | not elabBuildHaddocks = False
- | otherwise = any componentHasHaddocks components
- where
- components :: [ComponentTarget]
- components =
- elabBuildTargets
- ++ elabTestTargets
- ++ elabBenchTargets
- ++ elabReplTarget
- ++ elabHaddockTargets
-
- componentHasHaddocks :: ComponentTarget -> Bool
- componentHasHaddocks (ComponentTarget name _) =
- case name of
- CLibName LMainLibName -> hasHaddocks
- CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks
- CFLibName _ -> elabHaddockForeignLibs && hasHaddocks
- CExeName _ -> elabHaddockExecutables && hasHaddocks
- CTestName _ -> elabHaddockTestSuites && hasHaddocks
- CBenchName _ -> elabHaddockBenchmarks && hasHaddocks
- where
- hasHaddocks = not (null (elabPkgDescription ^. componentModules name))
-
-buildInplaceUnpackedPackage
- :: Verbosity
- -> DistDirLayout
- -> Maybe SemaphoreName
- -> BuildTimeSettings
- -> Lock
- -> Lock
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> ElaboratedReadyPackage
- -> BuildStatusRebuild
- -> FilePath
- -> FilePath
- -> IO BuildResult
-buildInplaceUnpackedPackage
- verbosity
- distDirLayout@DistDirLayout
- { distTempDirectory
- , distPackageCacheDirectory
- , distDirectory
- , distHaddockOutputDir
- }
- maybe_semaphore
- BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen}
- registerLock
- cacheLock
- pkgshared@ElaboratedSharedConfig
- { pkgConfigCompiler = compiler
- , pkgConfigCompilerProgs = progdb
- , pkgConfigPlatform = platform
- }
- plan
- rpkg@(ReadyPackage pkg)
- buildStatus
- srcdir
- builddir = do
- -- TODO: [code cleanup] there is duplication between the
- -- distdirlayout and the builddir here builddir is not
- -- enough, we also need the per-package cachedir
- createDirectoryIfMissingVerbose verbosity True builddir
- createDirectoryIfMissingVerbose
- verbosity
- True
- (distPackageCacheDirectory dparams)
-
- -- Configure phase
- --
- whenReConfigure $ do
- annotateFailureNoLog ConfigureFailed $
- setup configureCommand configureFlags configureArgs
- invalidatePackageRegFileMonitor packageFileMonitor
- updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
-
- -- Build phase
- --
- let docsResult = DocsNotTried
- testsResult = TestsNotTried
-
- buildResult :: BuildResultMisc
- buildResult = (docsResult, testsResult)
-
- whenRebuild $ do
- timestamp <- beginUpdateFileMonitor
- annotateFailureNoLog BuildFailed $
- setup buildCommand buildFlags buildArgs
-
- let listSimple =
- execRebuild srcdir (needElaboratedConfiguredPackage pkg)
- listSdist =
- fmap (map monitorFileHashed) $
- allPackageSourceFiles verbosity srcdir
- ifNullThen m m' = do
- xs <- m
- if null xs then m' else return xs
- monitors <- case PD.buildType (elabPkgDescription pkg) of
- Simple -> listSimple
- -- If a Custom setup was used, AND the Cabal is recent
- -- enough to have sdist --list-sources, use that to
- -- determine the files that we need to track. This can
- -- cause unnecessary rebuilding (for example, if README
- -- is edited, we will try to rebuild) but there isn't
- -- a more accurate Custom interface we can use to get
- -- this info. We prefer not to use listSimple here
- -- as it can miss extra source files that are considered
- -- by the Custom setup.
- _
- | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->
- -- However, sometimes sdist --list-sources will fail
- -- and return an empty list. In that case, fall
- -- back on the (inaccurate) simple tracking.
- listSdist `ifNullThen` listSimple
- | otherwise ->
- listSimple
-
- let dep_monitors =
- map monitorFileHashed $
- elabInplaceDependencyBuildCacheFiles
- distDirLayout
- pkgshared
- plan
- pkg
- updatePackageBuildFileMonitor
- packageFileMonitor
- srcdir
- timestamp
- pkg
- buildStatus
- (monitors ++ dep_monitors)
- buildResult
-
- -- PURPOSELY omitted: no copy!
-
- whenReRegister $ annotateFailureNoLog InstallFailed $ do
- -- Register locally
- mipkg <-
- if elabRequiresRegistration pkg
- then do
- ipkg0 <- generateInstalledPackageInfo
- -- We register ourselves rather than via Setup.hs. We need to
- -- grab and modify the InstalledPackageInfo. We decide what
- -- the installed package id is, not the build system.
- let ipkg = ipkg0{Installed.installedUnitId = ipkgid}
- criticalSection registerLock $
- Cabal.registerPackage
- verbosity
- compiler
- progdb
- (elabRegisterPackageDBStack pkg)
- ipkg
- Cabal.defaultRegisterOptions
- return (Just ipkg)
- else return Nothing
-
- updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
-
- whenTest $ do
- annotateFailureNoLog TestsFailed $
- setup testCommand testFlags testArgs
-
- whenBench $
- annotateFailureNoLog BenchFailed $
- setup benchCommand benchFlags benchArgs
-
- -- Repl phase
- --
- whenRepl $
- annotateFailureNoLog ReplFailed $
- setupInteractive replCommand replFlags replArgs
-
- -- Haddock phase
- whenHaddock $
- annotateFailureNoLog HaddocksFailed $ do
- setup haddockCommand haddockFlags haddockArgs
- let haddockTarget = elabHaddockForHackage pkg
- when (haddockTarget == Cabal.ForHackage) $ do
- let dest = distDirectory </> name <.> "tar.gz"
- name = haddockDirName haddockTarget (elabPkgDescription pkg)
- docDir =
- distBuildDirectory distDirLayout dparams
- </> "doc"
- </> "html"
- Tar.createTarGzFile dest docDir name
- notice verbosity $ "Documentation tarball created: " ++ dest
-
- when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do
- let dest = docDir </> "index.html"
- name = haddockDirName haddockTarget (elabPkgDescription pkg)
- docDir = case distHaddockOutputDir of
- Nothing -> distBuildDirectory distDirLayout dparams </> "doc" </> "html" </> name
- Just dir -> dir
- exe <- findOpenProgramLocation platform
- case exe of
- Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])
- Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err
-
- return
- BuildResult
- { buildResultDocs = docsResult
- , buildResultTests = testsResult
- , buildResultLogFile = Nothing
- }
- where
- ipkgid = installedUnitId pkg
- dparams = elabDistDirParams pkgshared pkg
-
- comp_par_strat = case maybe_semaphore of
- Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name)
- _ -> Cabal.NoFlag
-
- packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
-
- whenReConfigure action = case buildStatus of
- BuildStatusConfigure _ -> action
- _ -> return ()
-
- whenRebuild action
- | null (elabBuildTargets pkg)
- , -- NB: we have to build the test/bench suite!
- null (elabTestTargets pkg)
- , null (elabBenchTargets pkg) =
- return ()
- | otherwise = action
-
- whenTest action
- | null (elabTestTargets pkg) = return ()
- | otherwise = action
-
- whenBench action
- | null (elabBenchTargets pkg) = return ()
- | otherwise = action
-
- whenRepl action
- | null (elabReplTarget pkg) = return ()
- | otherwise = action
-
- whenHaddock action
- | hasValidHaddockTargets pkg = action
- | otherwise = return ()
-
- whenReRegister action =
- case buildStatus of
- -- We registered the package already
- BuildStatusBuild (Just _) _ ->
- info verbosity "whenReRegister: previously registered"
- -- There is nothing to register
- _
- | null (elabBuildTargets pkg) ->
- info verbosity "whenReRegister: nothing to register"
- | otherwise -> action
-
- configureCommand = Cabal.configureCommand defaultProgramDb
- configureFlags v =
- flip filterConfigureFlags v $
- setupHsConfigureFlags
- plan
- rpkg
- pkgshared
- verbosity
- builddir
- configureArgs _ = setupHsConfigureArgs pkg
-
- buildCommand = Cabal.buildCommand defaultProgramDb
- buildFlags _ =
- setupHsBuildFlags
- comp_par_strat
- pkg
- pkgshared
- verbosity
- builddir
- buildArgs _ = setupHsBuildArgs pkg
-
- testCommand = Cabal.testCommand -- defaultProgramDb
- testFlags v =
- flip filterTestFlags v $
- setupHsTestFlags
- pkg
- verbosity
- builddir
- testArgs _ = setupHsTestArgs pkg
-
- benchCommand = Cabal.benchmarkCommand
- benchFlags _ =
- setupHsBenchFlags
- pkg
- pkgshared
- verbosity
- builddir
- benchArgs _ = setupHsBenchArgs pkg
-
- replCommand = Cabal.replCommand defaultProgramDb
- replFlags _ =
- setupHsReplFlags
- pkg
- pkgshared
- verbosity
- builddir
- replArgs _ = setupHsReplArgs pkg
-
- haddockCommand = Cabal.haddockCommand
- haddockFlags v =
- flip filterHaddockFlags v $
- setupHsHaddockFlags
- pkg
- pkgshared
- verbosity
- builddir
- haddockArgs v =
- flip filterHaddockArgs v $
- setupHsHaddockArgs pkg
-
- scriptOptions =
- setupHsScriptOptions
- rpkg
- plan
- pkgshared
- distDirLayout
- srcdir
- builddir
- (isParallelBuild buildSettingNumJobs)
- cacheLock
-
- setupInteractive
- :: CommandUI flags
- -> (Version -> flags)
- -> (Version -> [String])
- -> IO ()
- setupInteractive cmd flags args =
- setupWrapper
- verbosity
- scriptOptions{isInteractive = True}
- (Just (elabPkgDescription pkg))
- cmd
- flags
- args
-
- setup
- :: CommandUI flags
- -> (Version -> flags)
- -> (Version -> [String])
- -> IO ()
- setup cmd flags args =
- setupWrapper
- verbosity
- scriptOptions
- (Just (elabPkgDescription pkg))
- cmd
- flags
- args
-
- generateInstalledPackageInfo :: IO InstalledPackageInfo
- generateInstalledPackageInfo =
- withTempInstalledPackageInfoFile
- verbosity
- distTempDirectory
- $ \pkgConfDest -> do
- let registerFlags _ =
- setupHsRegisterFlags
- pkg
- pkgshared
- verbosity
- builddir
- pkgConfDest
- setup Cabal.registerCommand registerFlags (const [])
-
-withTempInstalledPackageInfoFile
- :: Verbosity
- -> FilePath
- -> (FilePath -> IO ())
- -> IO InstalledPackageInfo
-withTempInstalledPackageInfoFile verbosity tempdir action =
- withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
- -- make absolute since @action@ will often change directory
- abs_dir <- canonicalizePath dir
-
- let pkgConfDest = abs_dir </> "pkgConf"
- action pkgConfDest
-
- readPkgConf "." pkgConfDest
- where
- pkgConfParseFailed :: String -> IO a
- pkgConfParseFailed perror =
- dieWithException verbosity $ PkgConfParseFailed perror
-
- readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
- readPkgConf pkgConfDir pkgConfFile = do
- pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)
- (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
- Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
- Right (warns, ipkg) -> return (warns, ipkg)
-
- unless (null warns) $
- warn verbosity $
- unlines warns
-
- return ipkg
-
-------------------------------------------------------------------------------
-
--- * Utilities
-
-------------------------------------------------------------------------------
-
-{- FOURMOLU_DISABLE -}
-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.
- -- So we take the strategy of catching everything except async exceptions.
- [
-#if MIN_VERSION_base(4,7,0)
- Handler $ \async -> throwIO (async :: SomeAsyncException)
-#else
- Handler $ \async -> throwIO (async :: AsyncException)
-#endif
- , Handler $ \other -> handler (other :: SomeException)
- ]
- where
- handler :: Exception e => e -> IO a
- handler = throwIO . BuildFailure mlogFile . annotate . toException
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
new file mode 100644
index 0000000000..b93064ea7b
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs
@@ -0,0 +1,294 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Distribution.Client.ProjectBuilding.PackageFileMonitor where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.Client.ProjectBuilding.Types
+import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Client.RebuildMonad
+
+import Distribution.Client.DistDirLayout
+import Distribution.Client.FileMonitor
+import Distribution.Client.Types hiding
+ ( BuildFailure (..)
+ , BuildOutcome
+ , BuildOutcomes
+ , BuildResult (..)
+ )
+
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.Simple.LocalBuildInfo
+ ( ComponentName (..)
+ )
+
+import qualified Data.Set as Set
+import Distribution.Client.Init.Types (removeExistingFile)
+
+-----------------------------
+-- Package change detection
+--
+
+-- | As part of the dry run for local unpacked packages we have to check if the
+-- package config or files have changed. That is the purpose of
+-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.
+--
+-- When a package is (re)built, the monitor must be updated to reflect the new
+-- state of the package. Because we sometimes build without reconfiguring the
+-- state updates are split into two, one for package config changes and one
+-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'
+-- and 'updatePackageBuildFileMonitor'.
+data PackageFileMonitor = PackageFileMonitor
+ { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage ()
+ , pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc
+ , pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
+ }
+
+-- | This is all the components of the 'BuildResult' other than the
+-- @['InstalledPackageInfo']@.
+--
+-- We have to split up the 'BuildResult' components since they get produced
+-- at different times (or rather, when different things change).
+type BuildResultMisc = (DocsResult, TestsResult)
+
+newPackageFileMonitor
+ :: ElaboratedSharedConfig
+ -> DistDirLayout
+ -> DistDirParams
+ -> PackageFileMonitor
+newPackageFileMonitor
+ shared
+ DistDirLayout{distPackageCacheFile}
+ dparams =
+ PackageFileMonitor
+ { pkgFileMonitorConfig =
+ FileMonitor
+ { fileMonitorCacheFile = distPackageCacheFile dparams "config"
+ , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared
+ , fileMonitorCheckIfOnlyValueChanged = False
+ }
+ , pkgFileMonitorBuild =
+ FileMonitor
+ { fileMonitorCacheFile = distPackageCacheFile dparams "build"
+ , fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt ->
+ componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt
+ , fileMonitorCheckIfOnlyValueChanged = True
+ }
+ , pkgFileMonitorReg =
+ newFileMonitor (distPackageCacheFile dparams "registration")
+ }
+
+-- | Helper function for 'checkPackageFileMonitorChanged',
+-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.
+--
+-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by
+-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.
+packageFileMonitorKeyValues
+ :: ElaboratedConfiguredPackage
+ -> (ElaboratedConfiguredPackage, Set ComponentName)
+packageFileMonitorKeyValues elab =
+ (elab_config, buildComponents)
+ where
+ -- The first part is the value used to guard (re)configuring the package.
+ -- That is, if this value changes then we will reconfigure.
+ -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of
+ -- information that affects the (re)configure step. But those parts that
+ -- do not affect the configure step need to be nulled out. Those parts are
+ -- the specific targets that we're going to build.
+ --
+
+ -- Additionally we null out the parts that don't affect the configure step because they're simply
+ -- about how tests or benchmarks are run
+
+ -- TODO there may be more things to null here too, in the future.
+
+ elab_config :: ElaboratedConfiguredPackage
+ elab_config =
+ elab
+ { elabBuildTargets = []
+ , elabTestTargets = []
+ , elabBenchTargets = []
+ , elabReplTarget = []
+ , elabHaddockTargets = []
+ , elabBuildHaddocks = False
+ , elabTestMachineLog = Nothing
+ , elabTestHumanLog = Nothing
+ , elabTestShowDetails = Nothing
+ , elabTestKeepTix = False
+ , elabTestTestOptions = []
+ , elabBenchmarkOptions = []
+ }
+
+ -- The second part is the value used to guard the build step. So this is
+ -- more or less the opposite of the first part, as it's just the info about
+ -- what targets we're going to build.
+ --
+ buildComponents :: Set ComponentName
+ buildComponents = elabBuildTargetWholeComponents elab
+
+-- | Do all the checks on whether a package has changed and thus needs either
+-- rebuilding or reconfiguring and rebuilding.
+checkPackageFileMonitorChanged
+ :: PackageFileMonitor
+ -> ElaboratedConfiguredPackage
+ -> FilePath
+ -> [BuildStatus]
+ -> IO (Either BuildStatusRebuild BuildResult)
+checkPackageFileMonitorChanged
+ PackageFileMonitor{..}
+ pkg
+ srcdir
+ depsBuildStatus = do
+ -- TODO: [nice to have] some debug-level message about file
+ -- changes, like rerunIfChanged
+ configChanged <-
+ checkFileMonitorChanged
+ pkgFileMonitorConfig
+ srcdir
+ pkgconfig
+ case configChanged of
+ MonitorChanged monitorReason ->
+ return (Left (BuildStatusConfigure monitorReason'))
+ where
+ monitorReason' = fmap (const ()) monitorReason
+ MonitorUnchanged () _
+ -- The configChanged here includes the identity of the dependencies,
+ -- so depsBuildStatus is just needed for the changes in the content
+ -- of dependencies.
+ | any buildStatusRequiresBuild depsBuildStatus -> do
+ regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
+ let mreg = changedToMaybe regChanged
+ return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))
+ | otherwise -> do
+ buildChanged <-
+ checkFileMonitorChanged
+ pkgFileMonitorBuild
+ srcdir
+ buildComponents
+ regChanged <-
+ checkFileMonitorChanged
+ pkgFileMonitorReg
+ srcdir
+ ()
+ let mreg = changedToMaybe regChanged
+ case (buildChanged, regChanged) of
+ (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->
+ return (Left (BuildStatusBuild mreg buildReason))
+ where
+ buildReason = BuildReasonExtraTargets prevBuildComponents
+ (MonitorChanged monitorReason, _) ->
+ return (Left (BuildStatusBuild mreg buildReason))
+ where
+ buildReason = BuildReasonFilesChanged monitorReason'
+ monitorReason' = fmap (const ()) monitorReason
+ (MonitorUnchanged _ _, MonitorChanged monitorReason) ->
+ -- this should only happen if the file is corrupt or been
+ -- manually deleted. We don't want to bother with another
+ -- phase just for this, so we'll reregister by doing a build.
+ return (Left (BuildStatusBuild Nothing buildReason))
+ where
+ buildReason = BuildReasonFilesChanged monitorReason'
+ monitorReason' = fmap (const ()) monitorReason
+ (MonitorUnchanged _ _, MonitorUnchanged _ _)
+ | pkgHasEphemeralBuildTargets pkg ->
+ return (Left (BuildStatusBuild mreg buildReason))
+ where
+ buildReason = BuildReasonEphemeralTargets
+ (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->
+ return $
+ Right
+ BuildResult
+ { buildResultDocs = docsResult
+ , buildResultTests = testsResult
+ , buildResultLogFile = Nothing
+ }
+ where
+ (docsResult, testsResult) = buildResult
+ where
+ (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
+ changedToMaybe :: MonitorChanged a b -> Maybe b
+ changedToMaybe (MonitorChanged _) = Nothing
+ changedToMaybe (MonitorUnchanged x _) = Just x
+
+updatePackageConfigFileMonitor
+ :: PackageFileMonitor
+ -> FilePath
+ -> ElaboratedConfiguredPackage
+ -> IO ()
+updatePackageConfigFileMonitor
+ PackageFileMonitor{pkgFileMonitorConfig}
+ srcdir
+ pkg =
+ updateFileMonitor
+ pkgFileMonitorConfig
+ srcdir
+ Nothing
+ []
+ pkgconfig
+ ()
+ where
+ (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg
+
+updatePackageBuildFileMonitor
+ :: PackageFileMonitor
+ -> FilePath
+ -> MonitorTimestamp
+ -> ElaboratedConfiguredPackage
+ -> BuildStatusRebuild
+ -> [MonitorFilePath]
+ -> BuildResultMisc
+ -> IO ()
+updatePackageBuildFileMonitor
+ PackageFileMonitor{pkgFileMonitorBuild}
+ srcdir
+ timestamp
+ pkg
+ pkgBuildStatus
+ monitors
+ buildResult =
+ updateFileMonitor
+ pkgFileMonitorBuild
+ srcdir
+ (Just timestamp)
+ monitors
+ buildComponents'
+ buildResult
+ where
+ (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
+
+ -- If the only thing that's changed is that we're now building extra
+ -- components, then we can avoid later unnecessary rebuilds by saving the
+ -- total set of components that have been built, namely the union of the
+ -- existing ones plus the new ones. If files also changed this would be
+ -- the wrong thing to do. Note that we rely on the
+ -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
+ -- that it's /only/ the value that changed not any files that changed.
+ buildComponents' =
+ case pkgBuildStatus of
+ BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) ->
+ buildComponents `Set.union` prevBuildComponents
+ _ -> buildComponents
+
+updatePackageRegFileMonitor
+ :: PackageFileMonitor
+ -> FilePath
+ -> Maybe InstalledPackageInfo
+ -> IO ()
+updatePackageRegFileMonitor
+ PackageFileMonitor{pkgFileMonitorReg}
+ srcdir
+ mipkg =
+ updateFileMonitor
+ pkgFileMonitorReg
+ srcdir
+ Nothing
+ []
+ ()
+ mipkg
+
+invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
+invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
+ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
new file mode 100644
index 0000000000..f0ce968a78
--- /dev/null
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs
@@ -0,0 +1,921 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | This module exposes functions to build and register unpacked packages.
+--
+-- Mainly, unpacked packages are either:
+-- * Built and registered in-place
+-- * Built and installed
+--
+-- The two cases differ significantly for there to be a distinction.
+-- For instance, we only care about file monitoring and re-building when dealing
+-- with "inplace" registered packages, whereas for installed packages we don't.
+module Distribution.Client.ProjectBuilding.UnpackedPackage
+ ( buildInplaceUnpackedPackage
+ , buildAndInstallUnpackedPackage
+
+ -- ** Auxiliary definitions
+ , buildAndRegisterUnpackedPackage
+ , PackageBuildingPhase
+
+ -- ** Utilities
+ , annotateFailure
+ , annotateFailureNoLog
+ ) where
+
+import Distribution.Client.Compat.Prelude
+import Prelude ()
+
+import Distribution.Client.PackageHash (renderPackageHashInputs)
+import Distribution.Client.ProjectBuilding.Types
+import Distribution.Client.ProjectConfig
+import Distribution.Client.ProjectConfig.Types
+import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Client.RebuildMonad
+import Distribution.Client.Store
+
+import Distribution.Client.DistDirLayout
+import Distribution.Client.FileMonitor
+import Distribution.Client.JobControl
+import Distribution.Client.Setup
+ ( filterConfigureFlags
+ , filterHaddockArgs
+ , filterHaddockFlags
+ , filterTestFlags
+ )
+import Distribution.Client.SetupWrapper
+import Distribution.Client.SourceFiles
+import Distribution.Client.SrcDist (allPackageSourceFiles)
+import qualified Distribution.Client.Tar as Tar
+import Distribution.Client.Types hiding
+ ( BuildFailure (..)
+ , BuildOutcome
+ , BuildOutcomes
+ , BuildResult (..)
+ )
+import Distribution.Client.Utils
+ ( ProgressPhase (..)
+ , findOpenProgramLocation
+ , progressMessage
+ )
+
+import Distribution.Compat.Lens
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import qualified Distribution.InstalledPackageInfo as Installed
+import Distribution.Package
+import qualified Distribution.PackageDescription as PD
+import Distribution.Simple.BuildPaths (haddockDirName)
+import Distribution.Simple.Command (CommandUI)
+import Distribution.Simple.Compiler
+ ( PackageDBStack
+ , compilerId
+ )
+import qualified Distribution.Simple.InstallDirs as InstallDirs
+import Distribution.Simple.LocalBuildInfo
+ ( ComponentName (..)
+ , LibraryName (..)
+ )
+import Distribution.Simple.Program
+import qualified Distribution.Simple.Register as Cabal
+import qualified Distribution.Simple.Setup as Cabal
+import Distribution.Types.BuildType
+import Distribution.Types.PackageDescription.Lens (componentModules)
+
+import Distribution.Simple.Utils
+import Distribution.Version
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
+import qualified Data.List.NonEmpty as NE
+
+import Control.Exception (Handler (..), SomeAsyncException, assert, catches)
+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile)
+import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), (</>))
+import System.IO (Handle, IOMode (AppendMode), withFile)
+import System.Semaphore (SemaphoreName (..))
+
+import Distribution.Client.Errors
+import Distribution.Compat.Directory (listDirectory)
+
+import Distribution.Client.ProjectBuilding.PackageFileMonitor
+
+-- | Each unpacked package is processed in the following phases:
+--
+-- * Configure phase
+-- * Build phase
+-- * Install phase (copy + register)
+-- * Register phase
+-- * Test phase
+-- * Bench phase
+-- * Repl phase
+-- * Haddock phase
+--
+-- Depending on whether we are installing the package or building it inplace,
+-- the phases will be carried out differently. For example, when installing,
+-- the test, benchmark, and repl phase are ignored.
+data PackageBuildingPhase
+ = PBConfigurePhase {runConfigure :: IO ()}
+ | PBBuildPhase {runBuild :: IO ()}
+ | PBHaddockPhase {runHaddock :: IO ()}
+ | PBInstallPhase
+ { runCopy :: FilePath -> IO ()
+ , runRegister
+ :: PackageDBStack
+ -> Cabal.RegisterOptions
+ -> IO InstalledPackageInfo
+ }
+ | PBTestPhase {runTest :: IO ()}
+ | PBBenchPhase {runBench :: IO ()}
+ | PBReplPhase {runRepl :: IO ()}
+
+-- | Structures the phases of building and registering a package amongst others
+-- (see t'PackageBuildingPhase'). Delegates logic specific to a certain
+-- building style (notably, inplace vs install) to the delegate function that
+-- receives as an argument t'PackageBuildingPhase')
+buildAndRegisterUnpackedPackage
+ :: Verbosity
+ -> DistDirLayout
+ -> Maybe SemaphoreName
+ -- ^ Whether to pass a semaphore to build process
+ -- this is different to BuildTimeSettings because the
+ -- name of the semaphore is created freshly each time.
+ -> BuildTimeSettings
+ -> Lock
+ -> Lock
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedReadyPackage
+ -> FilePath
+ -> FilePath
+ -> (PackageBuildingPhase -> IO ())
+ -> IO (Maybe FilePath)
+ -- ^ Returns the path to the /initialized/ log file configured in
+ -- t'BuildTimeSettings' ('buildSettingLogFile'), if one exists.
+buildAndRegisterUnpackedPackage
+ verbosity
+ distDirLayout@DistDirLayout{distTempDirectory}
+ maybe_semaphore
+ BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile}
+ registerLock
+ cacheLock
+ pkgshared@ElaboratedSharedConfig
+ { pkgConfigCompiler = compiler
+ , pkgConfigCompilerProgs = progdb
+ , pkgConfigPlatform = platform
+ }
+ plan
+ rpkg@(ReadyPackage pkg)
+ srcdir
+ builddir
+ delegate = do
+ initLogFile
+
+ -- Configure phase
+ delegate $
+ PBConfigurePhase $
+ annotateFailure mlogFile ConfigureFailed $
+ setup configureCommand configureFlags configureArgs
+
+ -- Build phase
+ delegate $
+ PBBuildPhase $
+ annotateFailure mlogFile BuildFailed $
+ setup buildCommand buildFlags buildArgs
+
+ -- Haddock phase
+ whenHaddock $
+ delegate $
+ PBHaddockPhase $
+ annotateFailure mlogFile HaddocksFailed $ do
+ setup haddockCommand haddockFlags haddockArgs
+
+ -- Install phase
+ delegate $
+ PBInstallPhase
+ { runCopy = \destdir ->
+ annotateFailure mlogFile InstallFailed $
+ setup Cabal.copyCommand (copyFlags destdir) (const [])
+ , runRegister = \pkgDBStack registerOpts ->
+ annotateFailure mlogFile InstallFailed $ do
+ -- We register ourselves rather than via Setup.hs. We need to
+ -- grab and modify the InstalledPackageInfo. We decide what
+ -- the installed package id is, not the build system.
+ ipkg0 <- generateInstalledPackageInfo
+ let ipkg = ipkg0{Installed.installedUnitId = uid}
+ criticalSection registerLock $
+ Cabal.registerPackage
+ verbosity
+ compiler
+ progdb
+ pkgDBStack
+ ipkg
+ registerOpts
+ return ipkg
+ }
+
+ -- Test phase
+ whenTest $
+ delegate $
+ PBTestPhase $
+ annotateFailure mlogFile TestsFailed $
+ setup testCommand testFlags testArgs
+
+ -- Bench phase
+ whenBench $
+ delegate $
+ PBBenchPhase $
+ annotateFailure mlogFile BenchFailed $
+ setup benchCommand benchFlags benchArgs
+
+ -- Repl phase
+ whenRepl $
+ delegate $
+ PBReplPhase $
+ annotateFailure mlogFile ReplFailed $
+ setupInteractive replCommand replFlags replArgs
+
+ return mlogFile
+ where
+ uid = installedUnitId rpkg
+ pkgid = packageId rpkg
+
+ comp_par_strat = case maybe_semaphore of
+ Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name)
+ _ -> Cabal.NoFlag
+
+ whenTest action
+ | null (elabTestTargets pkg) = return ()
+ | otherwise = action
+
+ whenBench action
+ | null (elabBenchTargets pkg) = return ()
+ | otherwise = action
+
+ whenRepl action
+ | null (elabReplTarget pkg) = return ()
+ | otherwise = action
+
+ whenHaddock action
+ | hasValidHaddockTargets pkg = action
+ | otherwise = return ()
+
+ configureCommand = Cabal.configureCommand defaultProgramDb
+ configureFlags v =
+ flip filterConfigureFlags v $
+ setupHsConfigureFlags
+ plan
+ rpkg
+ pkgshared
+ verbosity
+ builddir
+ configureArgs _ = setupHsConfigureArgs pkg
+
+ buildCommand = Cabal.buildCommand defaultProgramDb
+ buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir
+ buildArgs _ = setupHsBuildArgs pkg
+
+ copyFlags destdir _ =
+ setupHsCopyFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ destdir
+
+ testCommand = Cabal.testCommand -- defaultProgramDb
+ testFlags v =
+ flip filterTestFlags v $
+ setupHsTestFlags
+ pkg
+ verbosity
+ builddir
+ testArgs _ = setupHsTestArgs pkg
+
+ benchCommand = Cabal.benchmarkCommand
+ benchFlags _ =
+ setupHsBenchFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ benchArgs _ = setupHsBenchArgs pkg
+
+ replCommand = Cabal.replCommand defaultProgramDb
+ replFlags _ =
+ setupHsReplFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ replArgs _ = setupHsReplArgs pkg
+
+ haddockCommand = Cabal.haddockCommand
+ haddockFlags v =
+ flip filterHaddockFlags v $
+ setupHsHaddockFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ haddockArgs v =
+ flip filterHaddockArgs v $
+ setupHsHaddockArgs pkg
+
+ scriptOptions =
+ setupHsScriptOptions
+ rpkg
+ plan
+ pkgshared
+ distDirLayout
+ srcdir
+ builddir
+ (isParallelBuild buildSettingNumJobs)
+ cacheLock
+
+ setup
+ :: CommandUI flags
+ -> (Version -> flags)
+ -> (Version -> [String])
+ -> IO ()
+ setup cmd flags args =
+ withLogging $ \mLogFileHandle ->
+ setupWrapper
+ verbosity
+ scriptOptions
+ { useLoggingHandle = mLogFileHandle
+ , useExtraEnvOverrides =
+ dataDirsEnvironmentForPlan
+ distDirLayout
+ plan
+ }
+ (Just (elabPkgDescription pkg))
+ cmd
+ flags
+ args
+
+ setupInteractive
+ :: CommandUI flags
+ -> (Version -> flags)
+ -> (Version -> [String])
+ -> IO ()
+ setupInteractive cmd flags args =
+ setupWrapper
+ verbosity
+ scriptOptions{isInteractive = True}
+ (Just (elabPkgDescription pkg))
+ cmd
+ flags
+ args
+
+ generateInstalledPackageInfo :: IO InstalledPackageInfo
+ generateInstalledPackageInfo =
+ withTempInstalledPackageInfoFile
+ verbosity
+ distTempDirectory
+ $ \pkgConfDest -> do
+ let registerFlags _ =
+ setupHsRegisterFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ pkgConfDest
+ setup Cabal.registerCommand registerFlags (const [])
+
+ mlogFile :: Maybe FilePath
+ mlogFile =
+ case buildSettingLogFile of
+ Nothing -> Nothing
+ Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
+
+ initLogFile :: IO ()
+ initLogFile =
+ case mlogFile of
+ Nothing -> return ()
+ Just logFile -> do
+ createDirectoryIfMissing True (takeDirectory logFile)
+ exists <- doesFileExist logFile
+ when exists $ removeFile logFile
+
+ withLogging :: (Maybe Handle -> IO r) -> IO r
+ withLogging action =
+ case mlogFile of
+ Nothing -> action Nothing
+ Just logFile -> withFile logFile AppendMode (action . Just)
+
+--------------------------------------------------------------------------------
+
+-- * Build Inplace
+
+--------------------------------------------------------------------------------
+
+buildInplaceUnpackedPackage
+ :: Verbosity
+ -> DistDirLayout
+ -> Maybe SemaphoreName
+ -> BuildTimeSettings
+ -> Lock
+ -> Lock
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedReadyPackage
+ -> BuildStatusRebuild
+ -> FilePath
+ -> FilePath
+ -> IO BuildResult
+buildInplaceUnpackedPackage
+ verbosity
+ distDirLayout@DistDirLayout
+ { distPackageCacheDirectory
+ , distDirectory
+ , distHaddockOutputDir
+ }
+ maybe_semaphore
+ buildSettings@BuildTimeSettings{buildSettingHaddockOpen}
+ registerLock
+ cacheLock
+ pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = platform}
+ plan
+ rpkg@(ReadyPackage pkg)
+ buildStatus
+ srcdir
+ builddir = do
+ -- TODO: [code cleanup] there is duplication between the
+ -- distdirlayout and the builddir here builddir is not
+ -- enough, we also need the per-package cachedir
+ createDirectoryIfMissingVerbose verbosity True builddir
+ createDirectoryIfMissingVerbose
+ verbosity
+ True
+ (distPackageCacheDirectory dparams)
+
+ let docsResult = DocsNotTried
+ testsResult = TestsNotTried
+
+ buildResult :: BuildResultMisc
+ buildResult = (docsResult, testsResult)
+
+ mlogFile <- buildAndRegisterUnpackedPackage
+ verbosity
+ distDirLayout
+ maybe_semaphore
+ buildSettings
+ registerLock
+ cacheLock
+ pkgshared
+ plan
+ rpkg
+ srcdir
+ builddir
+ $ \case
+ PBConfigurePhase{runConfigure} -> do
+ whenReConfigure $ do
+ runConfigure
+ invalidatePackageRegFileMonitor packageFileMonitor
+ updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
+ PBBuildPhase{runBuild} -> do
+ whenRebuild $ do
+ timestamp <- beginUpdateFileMonitor
+ runBuild
+
+ let listSimple =
+ execRebuild srcdir (needElaboratedConfiguredPackage pkg)
+ listSdist =
+ fmap (map monitorFileHashed) $
+ allPackageSourceFiles verbosity srcdir
+ ifNullThen m m' = do
+ xs <- m
+ if null xs then m' else return xs
+ monitors <- case PD.buildType (elabPkgDescription pkg) of
+ Simple -> listSimple
+ -- If a Custom setup was used, AND the Cabal is recent
+ -- enough to have sdist --list-sources, use that to
+ -- determine the files that we need to track. This can
+ -- cause unnecessary rebuilding (for example, if README
+ -- is edited, we will try to rebuild) but there isn't
+ -- a more accurate Custom interface we can use to get
+ -- this info. We prefer not to use listSimple here
+ -- as it can miss extra source files that are considered
+ -- by the Custom setup.
+ _
+ | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->
+ -- However, sometimes sdist --list-sources will fail
+ -- and return an empty list. In that case, fall
+ -- back on the (inaccurate) simple tracking.
+ listSdist `ifNullThen` listSimple
+ | otherwise ->
+ listSimple
+
+ let dep_monitors =
+ map monitorFileHashed $
+ elabInplaceDependencyBuildCacheFiles
+ distDirLayout
+ pkgshared
+ plan
+ pkg
+ updatePackageBuildFileMonitor
+ packageFileMonitor
+ srcdir
+ timestamp
+ pkg
+ buildStatus
+ (monitors ++ dep_monitors)
+ buildResult
+ PBHaddockPhase{runHaddock} -> do
+ runHaddock
+ let haddockTarget = elabHaddockForHackage pkg
+ when (haddockTarget == Cabal.ForHackage) $ do
+ let dest = distDirectory </> name <.> "tar.gz"
+ name = haddockDirName haddockTarget (elabPkgDescription pkg)
+ docDir =
+ distBuildDirectory distDirLayout dparams
+ </> "doc"
+ </> "html"
+ Tar.createTarGzFile dest docDir name
+ notice verbosity $ "Documentation tarball created: " ++ dest
+
+ when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do
+ let dest = docDir </> "index.html"
+ name = haddockDirName haddockTarget (elabPkgDescription pkg)
+ docDir = case distHaddockOutputDir of
+ Nothing -> distBuildDirectory distDirLayout dparams </> "doc" </> "html" </> name
+ Just dir -> dir
+ exe <- findOpenProgramLocation platform
+ case exe of
+ Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])
+ Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err
+ PBInstallPhase{runCopy = _runCopy, runRegister} -> do
+ -- PURPOSELY omitted: no copy!
+
+ whenReRegister $ do
+ -- Register locally
+ mipkg <-
+ if elabRequiresRegistration pkg
+ then do
+ ipkg <-
+ runRegister
+ (elabRegisterPackageDBStack pkg)
+ Cabal.defaultRegisterOptions
+ return (Just ipkg)
+ else return Nothing
+
+ updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
+ PBTestPhase{runTest} -> runTest
+ PBBenchPhase{runBench} -> runBench
+ PBReplPhase{runRepl} -> runRepl
+
+ return
+ BuildResult
+ { buildResultDocs = docsResult
+ , buildResultTests = testsResult
+ , buildResultLogFile = mlogFile
+ }
+ where
+ dparams = elabDistDirParams pkgshared pkg
+
+ packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
+
+ whenReConfigure action = case buildStatus of
+ BuildStatusConfigure _ -> action
+ _ -> return ()
+
+ whenRebuild action
+ | null (elabBuildTargets pkg)
+ , -- NB: we have to build the test/bench suite!
+ null (elabTestTargets pkg)
+ , null (elabBenchTargets pkg) =
+ return ()
+ | otherwise = action
+
+ whenReRegister action =
+ case buildStatus of
+ -- We registered the package already
+ BuildStatusBuild (Just _) _ ->
+ info verbosity "whenReRegister: previously registered"
+ -- There is nothing to register
+ _
+ | null (elabBuildTargets pkg) ->
+ info verbosity "whenReRegister: nothing to register"
+ | otherwise -> action
+
+--------------------------------------------------------------------------------
+
+-- * Build and Install
+
+--------------------------------------------------------------------------------
+
+buildAndInstallUnpackedPackage
+ :: Verbosity
+ -> DistDirLayout
+ -> StoreDirLayout
+ -> Maybe SemaphoreName
+ -- ^ Whether to pass a semaphore to build process
+ -- this is different to BuildTimeSettings because the
+ -- name of the semaphore is created freshly each time.
+ -> BuildTimeSettings
+ -> Lock
+ -> Lock
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedReadyPackage
+ -> FilePath
+ -> FilePath
+ -> IO BuildResult
+buildAndInstallUnpackedPackage
+ verbosity
+ distDirLayout
+ storeDirLayout@StoreDirLayout
+ { storePackageDBStack
+ }
+ maybe_semaphore
+ buildSettings@BuildTimeSettings{buildSettingNumJobs}
+ registerLock
+ cacheLock
+ pkgshared@ElaboratedSharedConfig{pkgConfigCompiler = compiler}
+ plan
+ rpkg@(ReadyPackage pkg)
+ srcdir
+ builddir = do
+ createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)
+
+ -- TODO: [code cleanup] deal consistently with talking to older
+ -- Setup.hs versions, much like we do for ghc, with a proper
+ -- options type and rendering step which will also let us
+ -- call directly into the lib, rather than always going via
+ -- the lib's command line interface, which would also allow
+ -- passing data like installed packages, compiler, and
+ -- program db for a quicker configure.
+
+ -- TODO: [required feature] docs and tests
+ -- TODO: [required feature] sudo re-exec
+
+ mlogFile <- buildAndRegisterUnpackedPackage
+ verbosity
+ distDirLayout
+ maybe_semaphore
+ buildSettings
+ registerLock
+ cacheLock
+ pkgshared
+ plan
+ rpkg
+ srcdir
+ builddir
+ $ \case
+ PBConfigurePhase{runConfigure} -> do
+ noticeProgress ProgressStarting
+ runConfigure
+ PBBuildPhase{runBuild} -> do
+ noticeProgress ProgressBuilding
+ runBuild
+ PBHaddockPhase{runHaddock} -> do
+ noticeProgress ProgressHaddock
+ runHaddock
+ PBInstallPhase{runCopy, runRegister} -> do
+ noticeProgress ProgressInstalling
+
+ let registerPkg
+ | not (elabRequiresRegistration pkg) =
+ debug verbosity $
+ "registerPkg: elab does NOT require registration for "
+ ++ prettyShow uid
+ | otherwise = do
+ assert
+ ( elabRegisterPackageDBStack pkg
+ == storePackageDBStack compid
+ )
+ (return ())
+ _ <-
+ runRegister
+ (storePackageDBStack compid)
+ Cabal.defaultRegisterOptions
+ { Cabal.registerMultiInstance = True
+ , Cabal.registerSuppressFilesCheck = True
+ }
+ return ()
+
+ -- Actual installation
+ void $
+ newStoreEntry
+ verbosity
+ storeDirLayout
+ compid
+ uid
+ (copyPkgFiles verbosity pkgshared pkg runCopy)
+ registerPkg
+
+ -- No tests on install
+ PBTestPhase{} -> return ()
+ -- No bench on install
+ PBBenchPhase{} -> return ()
+ -- No repl on install
+ PBReplPhase{} -> return ()
+
+ -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right
+ -- thing. Although we do copy into an image dir and do the move into the
+ -- final location ourselves, perhaps we ought to do some sanity checks on
+ -- the image dir first.
+
+ -- TODO: [required eventually] note that for nix-style
+ -- installations it is not necessary to do the
+ -- 'withWin32SelfUpgrade' dance, but it would be necessary for a
+ -- shared bin dir.
+
+ -- TODO: [required feature] docs and test phases
+ let docsResult = DocsNotTried
+ testsResult = TestsNotTried
+
+ noticeProgress ProgressCompleted
+
+ return
+ BuildResult
+ { buildResultDocs = docsResult
+ , buildResultTests = testsResult
+ , buildResultLogFile = mlogFile
+ }
+ where
+ uid = installedUnitId rpkg
+ pkgid = packageId rpkg
+ compid = compilerId compiler
+
+ dispname :: String
+ dispname = case elabPkgOrComp pkg of
+ ElabPackage _ ->
+ prettyShow pkgid
+ ++ " (all, legacy fallback)"
+ ElabComponent comp ->
+ prettyShow pkgid
+ ++ " ("
+ ++ maybe "custom" prettyShow (compComponentName comp)
+ ++ ")"
+
+ noticeProgress :: ProgressPhase -> IO ()
+ noticeProgress phase =
+ when (isParallelBuild buildSettingNumJobs) $
+ progressMessage verbosity phase dispname
+
+-- | The copy part of the installation phase when doing build-and-install
+copyPkgFiles
+ :: Verbosity
+ -> ElaboratedSharedConfig
+ -> ElaboratedConfiguredPackage
+ -> (FilePath -> IO ())
+ -- ^ The 'runCopy' function which invokes ./Setup copy for the
+ -- given filepath
+ -> FilePath
+ -- ^ The temporary dir file path
+ -> IO (FilePath, [FilePath])
+copyPkgFiles verbosity pkgshared pkg runCopy tmpDir = do
+ let tmpDirNormalised = normalise tmpDir
+ runCopy tmpDirNormalised
+ -- Note that the copy command has put the files into
+ -- @$tmpDir/$prefix@ so we need to return this dir so
+ -- the store knows which dir will be the final store entry.
+ let prefix =
+ normalise $
+ dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
+ entryDir = tmpDirNormalised </> prefix
+
+ -- if there weren't anything to build, it might be that directory is not created
+ -- the @setup Cabal.copyCommand@ above might do nothing.
+ -- https://github.com/haskell/cabal/issues/4130
+ createDirectoryIfMissingVerbose verbosity True entryDir
+
+ let hashFileName = entryDir </> "cabal-hash.txt"
+ outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg)
+
+ info verbosity $
+ "creating file with the inputs used to compute the package hash: " ++ hashFileName
+
+ LBS.writeFile hashFileName outPkgHashInputs
+
+ debug verbosity "Package hash inputs:"
+ traverse_
+ (debug verbosity . ("> " ++))
+ (lines $ LBS.Char8.unpack outPkgHashInputs)
+
+ -- Ensure that there are no files in `tmpDir`, that are
+ -- not in `entryDir`. While this breaks the
+ -- prefix-relocatable property of the libraries, it is
+ -- necessary on macOS to stay under the load command limit
+ -- of the macOS mach-o linker. See also
+ -- @PackageHash.hashedInstalledPackageIdVeryShort@.
+ --
+ -- We also normalise paths to ensure that there are no
+ -- different representations for the same path. Like / and
+ -- \\ on windows under msys.
+ otherFiles <-
+ filter (not . isPrefixOf entryDir)
+ <$> listFilesRecursive tmpDirNormalised
+ -- Here's where we could keep track of the installed files
+ -- ourselves if we wanted to by making a manifest of the
+ -- files in the tmp dir.
+ return (entryDir, otherFiles)
+ where
+ listFilesRecursive :: FilePath -> IO [FilePath]
+ listFilesRecursive path = do
+ files <- fmap (path </>) <$> (listDirectory path)
+ allFiles <- for files $ \file -> do
+ isDir <- doesDirectoryExist file
+ if isDir
+ then listFilesRecursive file
+ else return [file]
+ return (concat allFiles)
+
+--------------------------------------------------------------------------------
+
+-- * Exported Utils
+
+--------------------------------------------------------------------------------
+
+{- FOURMOLU_DISABLE -}
+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.
+ -- So we take the strategy of catching everything except async exceptions.
+ [
+#if MIN_VERSION_base(4,7,0)
+ Handler $ \async -> throwIO (async :: SomeAsyncException)
+#else
+ Handler $ \async -> throwIO (async :: AsyncException)
+#endif
+ , Handler $ \other -> handler (other :: SomeException)
+ ]
+ where
+ handler :: Exception e => e -> IO a
+ handler = throwIO . BuildFailure mlogFile . annotate . toException
+
+--------------------------------------------------------------------------------
+-- * Other Utils
+--------------------------------------------------------------------------------
+
+hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
+hasValidHaddockTargets ElaboratedConfiguredPackage{..}
+ | not elabBuildHaddocks = False
+ | otherwise = any componentHasHaddocks components
+ where
+ components :: [ComponentTarget]
+ components =
+ elabBuildTargets
+ ++ elabTestTargets
+ ++ elabBenchTargets
+ ++ elabReplTarget
+ ++ elabHaddockTargets
+
+ componentHasHaddocks :: ComponentTarget -> Bool
+ componentHasHaddocks (ComponentTarget name _) =
+ case name of
+ CLibName LMainLibName -> hasHaddocks
+ CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks
+ CFLibName _ -> elabHaddockForeignLibs && hasHaddocks
+ CExeName _ -> elabHaddockExecutables && hasHaddocks
+ CTestName _ -> elabHaddockTestSuites && hasHaddocks
+ CBenchName _ -> elabHaddockBenchmarks && hasHaddocks
+ where
+ hasHaddocks = not (null (elabPkgDescription ^. componentModules name))
+
+withTempInstalledPackageInfoFile
+ :: Verbosity
+ -> FilePath
+ -> (FilePath -> IO ())
+ -> IO InstalledPackageInfo
+withTempInstalledPackageInfoFile verbosity tempdir action =
+ withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
+ -- make absolute since @action@ will often change directory
+ abs_dir <- canonicalizePath dir
+
+ let pkgConfDest = abs_dir </> "pkgConf"
+ action pkgConfDest
+
+ readPkgConf "." pkgConfDest
+ where
+ pkgConfParseFailed :: String -> IO a
+ pkgConfParseFailed perror =
+ dieWithException verbosity $ PkgConfParseFailed perror
+
+ readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
+ readPkgConf pkgConfDir pkgConfFile = do
+ pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)
+ (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
+ Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
+ Right (warns, ipkg) -> return (warns, ipkg)
+
+ unless (null warns) $
+ warn verbosity $
+ unlines warns
+
+ return ipkg
+
--
GitLab