From d6506db793c0e37a393772fcb1d08033bea0f580 Mon Sep 17 00:00:00 2001 From: Rodrigo Mesquita 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 3cb68deb661..7e2250c41ca 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -151,6 +151,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 84ae5da18e8..a0906686dd1 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 00000000000..b93064ea7be --- /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 00000000000..f0ce968a78d --- /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 +