{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}

module Distribution.Client.ProjectBuilding
  ( -- * Dry run phase

    -- | What bits of the plan will we execute? The dry run does not change
    -- anything but tells us what will need to be built.
    rebuildTargetsDryRun
  , improveInstallPlanWithUpToDatePackages

    -- ** Build status

    -- | This is the detailed status information we get from the dry run.
  , BuildStatusMap
  , BuildStatus (..)
  , BuildStatusRebuild (..)
  , BuildReason (..)
  , MonitorChangedReason (..)
  , buildStatusToString

    -- * Build phase

    -- | Now we actually execute the plan.
  , rebuildTargets

    -- ** Build outcomes

    -- | This is the outcome for each package of executing the plan.
    -- For each package, did the build succeed or fail?
  , BuildOutcomes
  , BuildOutcome
  , BuildResult (..)
  , BuildFailure (..)
  , BuildFailureReason (..)
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

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.Store

import Distribution.Client.DistDirLayout
import Distribution.Client.FetchUtils
import Distribution.Client.GlobalFlags (RepoContext)
import Distribution.Client.InstallPlan
  ( GenericInstallPlan
  , GenericPlanPackage
  , IsUnit
  )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.JobControl
import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types hiding
  ( BuildFailure (..)
  , BuildOutcome
  , BuildOutcomes
  , BuildResult (..)
  )

import Distribution.Package
import Distribution.Simple.Compiler
import Distribution.Simple.Program
import qualified Distribution.Simple.Register as Cabal

import Distribution.Compat.Graph (IsNode (..))
import Distribution.Simple.Utils
import Distribution.Utils.Path hiding
  ( (<.>)
  , (</>)
  )
import Distribution.Version

import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Text.PrettyPrint as Disp

import Control.Exception (assert, bracket, handle)
import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))
import System.Semaphore (SemaphoreName (..))

import Distribution.Client.Errors
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.

------------------------------------------------------------------------------
--
-- We start with an 'ElaboratedInstallPlan' that has already been improved by
-- reusing packages from the store, and pruned to include only the targets of
-- interest and their dependencies. So the remaining packages in the
-- 'InstallPlan.Configured' state are ones we either need to build or rebuild.
--
-- First, we do a preliminary dry run phase where we work out which packages
-- we really need to (re)build, and for the ones we do need to build which
-- build phase to start at.
--
-- We use this to improve the 'ElaboratedInstallPlan' again by changing
-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'
-- so that the build phase will skip them.
--
-- Then we execute the plan, that is actually build packages. The outcomes of
-- trying to build all the packages are collected and returned.
--
-- We split things like this (dry run and execute) for a couple reasons.
-- Firstly we need to be able to do dry runs anyway, and these need to be
-- reasonably accurate in terms of letting users know what (and why) things
-- are going to be (re)built.
--
-- Given that we need to be able to do dry runs, it would not be great if
-- we had to repeat all the same work when we do it for real. Not only is
-- it duplicate work, but it's duplicate code which is likely to get out of
-- sync. So we do things only once. We preserve info we discover in the dry
-- run phase and rely on it later when we build things for real. This also
-- somewhat simplifies the build phase. So this way the dry run can't so
-- easily drift out of sync with the real thing since we're relying on the
-- info it produces.
--
-- An additional advantage is that it makes it easier to debug rebuild
-- errors (ie rebuilding too much or too little), since all the rebuild
-- decisions are made without making any state changes at the same time
-- (that would make it harder to reproduce the problem situation).
--
-- Finally, we can use the dry run build status and the build outcomes to
-- give us some information on the overall status of packages in the project.
-- This includes limited information about the status of things that were
-- not actually in the subset of the plan that was used for the dry run or
-- execution phases. In particular we may know that some packages are now
-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for
-- details.

------------------------------------------------------------------------------

-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?

------------------------------------------------------------------------------

-- Refer to ProjectBuilding.Types for details of these important types:

-- type BuildStatusMap     = ...
-- data BuildStatus        = ...
-- data BuildStatusRebuild = ...
-- data BuildReason        = ...

-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
--
-- It gives us the 'BuildStatusMap'. This should be used with
-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
rebuildTargetsDryRun
  :: DistDirLayout
  -> ElaboratedSharedConfig
  -> ElaboratedInstallPlan
  -> IO BuildStatusMap
rebuildTargetsDryRun :: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> IO BuildStatusMap
rebuildTargetsDryRun distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{FilePath
Maybe FilePath
FilePath -> FilePath
CompilerId -> PackageDBCWD
PackageIdentifier -> FilePath
DistDirParams -> FilePath
DistDirParams -> FilePath -> FilePath
distProjectRootDirectory :: FilePath
distProjectFile :: FilePath -> FilePath
distDirectory :: FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildRootDirectory :: FilePath
distDownloadSrcDirectory :: FilePath
distUnpackedSrcDirectory :: PackageIdentifier -> FilePath
distUnpackedSrcRootDirectory :: FilePath
distProjectCacheFile :: FilePath -> FilePath
distProjectCacheDirectory :: FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distSdistFile :: PackageIdentifier -> FilePath
distSdistDirectory :: FilePath
distTempDirectory :: FilePath
distBinDirectory :: FilePath
distPackageDB :: CompilerId -> PackageDBCWD
distHaddockOutputDir :: Maybe FilePath
distProjectRootDirectory :: DistDirLayout -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distDirectory :: DistDirLayout -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildRootDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distUnpackedSrcDirectory :: DistDirLayout -> PackageIdentifier -> FilePath
distUnpackedSrcRootDirectory :: DistDirLayout -> FilePath
distProjectCacheFile :: DistDirLayout -> FilePath -> FilePath
distProjectCacheDirectory :: DistDirLayout -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distSdistFile :: DistDirLayout -> PackageIdentifier -> FilePath
distSdistDirectory :: DistDirLayout -> FilePath
distTempDirectory :: DistDirLayout -> FilePath
distBinDirectory :: DistDirLayout -> FilePath
distPackageDB :: DistDirLayout -> CompilerId -> PackageDBCWD
distHaddockOutputDir :: DistDirLayout -> Maybe FilePath
..} ElaboratedSharedConfig
shared =
  -- Do the various checks to work out the 'BuildStatus' of each package
  (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> [BuildStatus] -> IO BuildStatus)
-> ElaboratedInstallPlan -> IO BuildStatusMap
forall (m :: * -> *) ipkg srcpkg b.
(Monad m, IsUnit ipkg, IsUnit srcpkg) =>
(GenericPlanPackage ipkg srcpkg -> [b] -> m b)
-> GenericInstallPlan ipkg srcpkg -> m (Map UnitId b)
foldMInstallPlanDepOrder GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> [BuildStatus] -> IO BuildStatus
dryRunPkg
  where
    dryRunPkg
      :: ElaboratedPlanPackage
      -> [BuildStatus]
      -> IO BuildStatus
    dryRunPkg :: GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> [BuildStatus] -> IO BuildStatus
dryRunPkg (InstallPlan.PreExisting InstalledPackageInfo
_pkg) [BuildStatus]
_depsBuildStatus =
      BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildStatus
BuildStatusPreExisting
    dryRunPkg (InstallPlan.Installed ElaboratedConfiguredPackage
_pkg) [BuildStatus]
_depsBuildStatus =
      BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildStatus
BuildStatusInstalled
    dryRunPkg (InstallPlan.Configured ElaboratedConfiguredPackage
pkg) [BuildStatus]
depsBuildStatus = do
      Maybe ResolvedPkgLoc
mloc <- UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc)
checkFetched (ElaboratedConfiguredPackage -> UnresolvedPkgLoc
elabPkgSourceLocation ElaboratedConfiguredPackage
pkg)
      case Maybe ResolvedPkgLoc
mloc of
        Maybe ResolvedPkgLoc
Nothing -> BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildStatus
BuildStatusDownload
        Just (LocalUnpackedPackage FilePath
srcdir) ->
          -- For the case of a user-managed local dir, irrespective of the
          -- build style, we build from that directory and put build
          -- artifacts under the shared dist directory.
          ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunLocalPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
srcdir
        -- The rest cases are all tarball cases are,
        -- and handled the same as each other though depending on the build style.
        Just (LocalTarballPackage FilePath
tarball) ->
          ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunTarballPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
tarball
        Just (RemoteTarballPackage URI
_ FilePath
tarball) ->
          ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunTarballPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
tarball
        Just (RepoTarballPackage Repo
_ PackageIdentifier
_ FilePath
tarball) ->
          ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunTarballPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
tarball
        Just (RemoteSourceRepoPackage SourceRepoMaybe
_repo FilePath
tarball) ->
          ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunTarballPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
tarball

    dryRunTarballPkg
      :: ElaboratedConfiguredPackage
      -> [BuildStatus]
      -> FilePath
      -> IO BuildStatus
    dryRunTarballPkg :: ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunTarballPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
tarball =
      case ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg of
        BuildStyle
BuildAndInstall -> BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> BuildStatus
BuildStatusUnpack FilePath
tarball)
        BuildInplaceOnly{} -> do
          -- TODO: [nice to have] use a proper file monitor rather
          -- than this dir exists test
          Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
srcdir
          if Bool
exists
            then ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunLocalPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
srcdir
            else BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> BuildStatus
BuildStatusUnpack FilePath
tarball)
      where
        srcdir :: FilePath
        srcdir :: FilePath
srcdir = PackageIdentifier -> FilePath
distUnpackedSrcDirectory (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg)

    dryRunLocalPkg
      :: ElaboratedConfiguredPackage
      -> [BuildStatus]
      -> FilePath
      -> IO BuildStatus
    dryRunLocalPkg :: ElaboratedConfiguredPackage
-> [BuildStatus] -> FilePath -> IO BuildStatus
dryRunLocalPkg ElaboratedConfiguredPackage
pkg [BuildStatus]
depsBuildStatus FilePath
srcdir = do
      -- Go and do lots of I/O, reading caches and probing files to work out
      -- if anything has changed
      Either BuildStatusRebuild BuildResult
change <-
        PackageFileMonitor
-> ElaboratedConfiguredPackage
-> FilePath
-> [BuildStatus]
-> IO (Either BuildStatusRebuild BuildResult)
checkPackageFileMonitorChanged
          PackageFileMonitor
packageFileMonitor
          ElaboratedConfiguredPackage
pkg
          FilePath
srcdir
          [BuildStatus]
depsBuildStatus
      case Either BuildStatusRebuild BuildResult
change of
        -- It did change, giving us 'BuildStatusRebuild' info on why
        Left BuildStatusRebuild
rebuild ->
          BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> BuildStatusRebuild -> BuildStatus
BuildStatusRebuild FilePath
srcdir BuildStatusRebuild
rebuild)
        -- No changes, the package is up to date. Use the saved build results.
        Right BuildResult
buildResult ->
          BuildStatus -> IO BuildStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildResult -> BuildStatus
BuildStatusUpToDate BuildResult
buildResult)
      where
        packageFileMonitor :: PackageFileMonitor
        packageFileMonitor :: PackageFileMonitor
packageFileMonitor =
          ElaboratedSharedConfig
-> DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor
            ElaboratedSharedConfig
shared
            DistDirLayout
distDirLayout
            (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
shared ElaboratedConfiguredPackage
pkg)

-- | A specialised traversal over the packages in an install plan.
--
-- The packages are visited in dependency order, starting with packages with no
-- dependencies. The result for each package is accumulated into a 'Map' and
-- returned as the final result. In addition, when visiting a package, the
-- visiting function is passed the results for all the immediate package
-- dependencies. This can be used to propagate information from dependencies.
foldMInstallPlanDepOrder
  :: forall m ipkg srcpkg b
   . (Monad m, IsUnit ipkg, IsUnit srcpkg)
  => ( GenericPlanPackage ipkg srcpkg
       -> [b]
       -> m b
     )
  -> GenericInstallPlan ipkg srcpkg
  -> m (Map UnitId b)
foldMInstallPlanDepOrder :: forall (m :: * -> *) ipkg srcpkg b.
(Monad m, IsUnit ipkg, IsUnit srcpkg) =>
(GenericPlanPackage ipkg srcpkg -> [b] -> m b)
-> GenericInstallPlan ipkg srcpkg -> m (Map UnitId b)
foldMInstallPlanDepOrder GenericPlanPackage ipkg srcpkg -> [b] -> m b
visit =
  Map UnitId b
-> [GenericPlanPackage ipkg srcpkg] -> m (Map UnitId b)
go Map UnitId b
forall k a. Map k a
Map.empty ([GenericPlanPackage ipkg srcpkg] -> m (Map UnitId b))
-> (GenericInstallPlan ipkg srcpkg
    -> [GenericPlanPackage ipkg srcpkg])
-> GenericInstallPlan ipkg srcpkg
-> m (Map UnitId b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.reverseTopologicalOrder
  where
    go
      :: Map UnitId b
      -> [GenericPlanPackage ipkg srcpkg]
      -> m (Map UnitId b)
    go :: Map UnitId b
-> [GenericPlanPackage ipkg srcpkg] -> m (Map UnitId b)
go !Map UnitId b
results [] = Map UnitId b -> m (Map UnitId b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Map UnitId b
results
    go !Map UnitId b
results (GenericPlanPackage ipkg srcpkg
pkg : [GenericPlanPackage ipkg srcpkg]
pkgs) = do
      -- we go in the right order so the results map has entries for all deps
      let depresults :: [b]
          depresults :: [b]
depresults =
            (UnitId -> b) -> [UnitId] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \UnitId
ipkgid ->
                  let result :: b
result = b -> UnitId -> Map UnitId b -> b
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (FilePath -> b
forall a. HasCallStack => FilePath -> a
error FilePath
"foldMInstallPlanDepOrder") UnitId
ipkgid Map UnitId b
results
                   in b
result
              )
              (GenericPlanPackage ipkg srcpkg -> [UnitId]
forall a. IsUnit a => a -> [UnitId]
InstallPlan.depends GenericPlanPackage ipkg srcpkg
pkg)
      b
result <- GenericPlanPackage ipkg srcpkg -> [b] -> m b
visit GenericPlanPackage ipkg srcpkg
pkg [b]
depresults
      let results' :: Map UnitId b
results' = UnitId -> b -> Map UnitId b -> Map UnitId b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericPlanPackage ipkg srcpkg
-> Key (GenericPlanPackage ipkg srcpkg)
forall a. IsNode a => a -> Key a
nodeKey GenericPlanPackage ipkg srcpkg
pkg) b
result Map UnitId b
results
      Map UnitId b
-> [GenericPlanPackage ipkg srcpkg] -> m (Map UnitId b)
go Map UnitId b
results' [GenericPlanPackage ipkg srcpkg]
pkgs

improveInstallPlanWithUpToDatePackages
  :: BuildStatusMap
  -> ElaboratedInstallPlan
  -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages :: BuildStatusMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages BuildStatusMap
pkgsBuildStatus =
  (ElaboratedConfiguredPackage -> Bool)
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
(srcpkg -> Bool)
-> GenericInstallPlan ipkg srcpkg -> GenericInstallPlan ipkg srcpkg
InstallPlan.installed ElaboratedConfiguredPackage -> Bool
canPackageBeImproved
  where
    canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
    canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
canPackageBeImproved ElaboratedConfiguredPackage
pkg =
      case UnitId -> BuildStatusMap -> Maybe BuildStatus
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg) BuildStatusMap
pkgsBuildStatus of
        Just BuildStatusUpToDate{} -> Bool
True
        Just BuildStatus
_ -> Bool
False
        Maybe BuildStatus
Nothing ->
          FilePath -> Bool
forall a. HasCallStack => FilePath -> a
error (FilePath -> Bool) -> FilePath -> Bool
forall a b. (a -> b) -> a -> b
$
            FilePath
"improveInstallPlanWithUpToDatePackages: "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg)
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not in status map"

------------------------------------------------------------------------------

-- * Doing it: executing an 'ElaboratedInstallPlan'

------------------------------------------------------------------------------

-- Refer to ProjectBuilding.Types for details of these important types:

-- type BuildOutcomes = ...
-- type BuildOutcome  = ...
-- data BuildResult   = ...
-- data BuildFailure  = ...
-- data BuildFailureReason = ...

-- | Build things for real.
--
-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
rebuildTargets
  :: Verbosity
  -> ProjectConfig
  -> DistDirLayout
  -> StoreDirLayout
  -> ElaboratedInstallPlan
  -> ElaboratedSharedConfig
  -> BuildStatusMap
  -> BuildTimeSettings
  -> IO BuildOutcomes
rebuildTargets :: Verbosity
-> ProjectConfig
-> DistDirLayout
-> StoreDirLayout
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
-> BuildTimeSettings
-> IO BuildOutcomes
rebuildTargets
  Verbosity
verbosity
  ProjectConfig
    { projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly = ProjectConfigBuildOnly
config
    }
  distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{FilePath
Maybe FilePath
FilePath -> FilePath
CompilerId -> PackageDBCWD
PackageIdentifier -> FilePath
DistDirParams -> FilePath
DistDirParams -> FilePath -> FilePath
distProjectRootDirectory :: DistDirLayout -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distDirectory :: DistDirLayout -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildRootDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distUnpackedSrcDirectory :: DistDirLayout -> PackageIdentifier -> FilePath
distUnpackedSrcRootDirectory :: DistDirLayout -> FilePath
distProjectCacheFile :: DistDirLayout -> FilePath -> FilePath
distProjectCacheDirectory :: DistDirLayout -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distSdistFile :: DistDirLayout -> PackageIdentifier -> FilePath
distSdistDirectory :: DistDirLayout -> FilePath
distTempDirectory :: DistDirLayout -> FilePath
distBinDirectory :: DistDirLayout -> FilePath
distPackageDB :: DistDirLayout -> CompilerId -> PackageDBCWD
distHaddockOutputDir :: DistDirLayout -> Maybe FilePath
distProjectRootDirectory :: FilePath
distProjectFile :: FilePath -> FilePath
distDirectory :: FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildRootDirectory :: FilePath
distDownloadSrcDirectory :: FilePath
distUnpackedSrcDirectory :: PackageIdentifier -> FilePath
distUnpackedSrcRootDirectory :: FilePath
distProjectCacheFile :: FilePath -> FilePath
distProjectCacheDirectory :: FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distSdistFile :: PackageIdentifier -> FilePath
distSdistDirectory :: FilePath
distTempDirectory :: FilePath
distBinDirectory :: FilePath
distPackageDB :: CompilerId -> PackageDBCWD
distHaddockOutputDir :: Maybe FilePath
..}
  StoreDirLayout
storeDirLayout
  ElaboratedInstallPlan
installPlan
  sharedPackageConfig :: ElaboratedSharedConfig
sharedPackageConfig@ElaboratedSharedConfig
    { pkgConfigCompiler :: ElaboratedSharedConfig -> Compiler
pkgConfigCompiler = Compiler
compiler
    , pkgConfigCompilerProgs :: ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs = ProgramDb
progdb
    }
  BuildStatusMap
pkgsBuildStatus
  buildSettings :: BuildTimeSettings
buildSettings@BuildTimeSettings
    { ParStratInstall
buildSettingNumJobs :: ParStratInstall
buildSettingNumJobs :: BuildTimeSettings -> ParStratInstall
buildSettingNumJobs
    , Bool
buildSettingKeepGoing :: Bool
buildSettingKeepGoing :: BuildTimeSettings -> Bool
buildSettingKeepGoing
    }
    | Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ProjectConfigBuildOnly -> Flag Bool
projectConfigOfflineMode ProjectConfigBuildOnly
config) Bool -> Bool -> Bool
&& Bool -> Bool
not ([ElaboratedConfiguredPackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ElaboratedConfiguredPackage]
packagesToDownload) = BuildOutcomes -> IO BuildOutcomes
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcomes
offlineError
    | Bool
otherwise = do
        -- Concurrency control: create the job controller and concurrency limits
        -- for downloading, building and installing.
        JobControl IO (UnitId, Either BuildFailure BuildResult)
mkJobControl <- case ParStratInstall
buildSettingNumJobs of
          ParStratInstall
Serial -> IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. IO (JobControl IO a)
newSerialJobControl
          NumJobs Maybe Int
n -> Int -> IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
numberOfProcessors Maybe Int
n)
          UseSem Int
n ->
            if Compiler -> Bool
jsemSupported Compiler
compiler
              then Verbosity
-> Int
-> IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. WithCallStack (Verbosity -> Int -> IO (JobControl IO a))
newSemaphoreJobControl Verbosity
verbosity Int
n
              else do
                Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
"-jsem is not supported by the selected compiler, falling back to normal parallelism control."
                Int -> IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl Int
n
        Lock
registerLock <- IO Lock
newLock -- serialise registration
        Lock
cacheLock <- IO Lock
newLock -- serialise access to setup exe cache
        -- TODO: [code cleanup] eliminate setup exe cache
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"Executing install plan "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ case ParStratInstall
buildSettingNumJobs of
              NumJobs Maybe Int
n -> FilePath
"in parallel using " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Maybe Int -> FilePath
forall a. Show a => a -> FilePath
show Maybe Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" threads."
              UseSem Int
n -> FilePath
"in parallel using a semaphore with " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" slots."
              ParStratInstall
Serial -> FilePath
"serially."

        Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
distBuildRootDirectory
        Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
distTempDirectory
        (PackageDBCWD -> IO ()) -> [PackageDBCWD] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> Compiler -> ProgramDb -> PackageDBCWD -> IO ()
createPackageDBIfMissing Verbosity
verbosity Compiler
compiler ProgramDb
progdb) [PackageDBCWD]
packageDBsToUse

        IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
-> (JobControl IO (UnitId, Either BuildFailure BuildResult)
    -> IO ())
-> (JobControl IO (UnitId, Either BuildFailure BuildResult)
    -> IO BuildOutcomes)
-> IO BuildOutcomes
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (JobControl IO (UnitId, Either BuildFailure BuildResult)
-> IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure JobControl IO (UnitId, Either BuildFailure BuildResult)
mkJobControl) JobControl IO (UnitId, Either BuildFailure BuildResult) -> IO ()
forall (m :: * -> *) a. JobControl m a -> m ()
cleanupJobControl ((JobControl IO (UnitId, Either BuildFailure BuildResult)
  -> IO BuildOutcomes)
 -> IO BuildOutcomes)
-> (JobControl IO (UnitId, Either BuildFailure BuildResult)
    -> IO BuildOutcomes)
-> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \JobControl IO (UnitId, Either BuildFailure BuildResult)
jobControl -> do
          -- Before traversing the install plan, preemptively find all packages that
          -- will need to be downloaded and start downloading them.
          Verbosity
-> ((RepoContext -> IO BuildOutcomes) -> IO BuildOutcomes)
-> ElaboratedInstallPlan
-> BuildStatusMap
-> (AsyncFetchMap -> IO BuildOutcomes)
-> IO BuildOutcomes
forall a.
Verbosity
-> ((RepoContext -> IO a) -> IO a)
-> ElaboratedInstallPlan
-> BuildStatusMap
-> (AsyncFetchMap -> IO a)
-> IO a
asyncDownloadPackages
            Verbosity
verbosity
            (RepoContext -> IO BuildOutcomes) -> IO BuildOutcomes
forall {a}. (RepoContext -> IO a) -> IO a
withRepoCtx
            ElaboratedInstallPlan
installPlan
            BuildStatusMap
pkgsBuildStatus
            ((AsyncFetchMap -> IO BuildOutcomes) -> IO BuildOutcomes)
-> (AsyncFetchMap -> IO BuildOutcomes) -> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \AsyncFetchMap
downloadMap ->
              -- For each package in the plan, in dependency order, but in parallel...
              JobControl IO (UnitId, Either BuildFailure BuildResult)
-> Bool
-> (ElaboratedConfiguredPackage -> BuildFailure)
-> ElaboratedInstallPlan
-> (GenericReadyPackage ElaboratedConfiguredPackage
    -> IO (Either BuildFailure BuildResult))
-> IO BuildOutcomes
forall (m :: * -> *) ipkg srcpkg result failure.
(IsUnit ipkg, IsUnit srcpkg, Monad m) =>
JobControl m (UnitId, Either failure result)
-> Bool
-> (srcpkg -> failure)
-> GenericInstallPlan ipkg srcpkg
-> (GenericReadyPackage srcpkg -> m (Either failure result))
-> m (BuildOutcomes failure result)
InstallPlan.execute
                JobControl IO (UnitId, Either BuildFailure BuildResult)
mkJobControl
                Bool
keepGoing
                (Maybe FilePath -> BuildFailureReason -> BuildFailure
BuildFailure Maybe FilePath
forall a. Maybe a
Nothing (BuildFailureReason -> BuildFailure)
-> (ElaboratedConfiguredPackage -> BuildFailureReason)
-> ElaboratedConfiguredPackage
-> BuildFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> BuildFailureReason
DependentFailed (PackageIdentifier -> BuildFailureReason)
-> (ElaboratedConfiguredPackage -> PackageIdentifier)
-> ElaboratedConfiguredPackage
-> BuildFailureReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId)
                ElaboratedInstallPlan
installPlan
                ((GenericReadyPackage ElaboratedConfiguredPackage
  -> IO (Either BuildFailure BuildResult))
 -> IO BuildOutcomes)
-> (GenericReadyPackage ElaboratedConfiguredPackage
    -> IO (Either BuildFailure BuildResult))
-> IO BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \GenericReadyPackage ElaboratedConfiguredPackage
pkg ->
                  -- TODO: review exception handling
                  (BuildFailure -> IO (Either BuildFailure BuildResult))
-> IO (Either BuildFailure BuildResult)
-> IO (Either BuildFailure BuildResult)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(BuildFailure
e :: BuildFailure) -> Either BuildFailure BuildResult
-> IO (Either BuildFailure BuildResult)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildFailure -> Either BuildFailure BuildResult
forall a b. a -> Either a b
Left BuildFailure
e)) (IO (Either BuildFailure BuildResult)
 -> IO (Either BuildFailure BuildResult))
-> IO (Either BuildFailure BuildResult)
-> IO (Either BuildFailure BuildResult)
forall a b. (a -> b) -> a -> b
$ (BuildResult -> Either BuildFailure BuildResult)
-> IO BuildResult -> IO (Either BuildFailure BuildResult)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BuildResult -> Either BuildFailure BuildResult
forall a b. b -> Either a b
Right (IO BuildResult -> IO (Either BuildFailure BuildResult))
-> IO BuildResult -> IO (Either BuildFailure BuildResult)
forall a b. (a -> b) -> a -> b
$ do
                    let uid :: UnitId
uid = GenericReadyPackage ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage ElaboratedConfiguredPackage
pkg
                        pkgBuildStatus :: BuildStatus
pkgBuildStatus = BuildStatus -> UnitId -> BuildStatusMap -> BuildStatus
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (FilePath -> BuildStatus
forall a. HasCallStack => FilePath -> a
error FilePath
"rebuildTargets") UnitId
uid BuildStatusMap
pkgsBuildStatus

                    Verbosity
-> DistDirLayout
-> StoreDirLayout
-> Maybe SemaphoreName
-> BuildTimeSettings
-> AsyncFetchMap
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> BuildStatus
-> IO BuildResult
rebuildTarget
                      Verbosity
verbosity
                      DistDirLayout
distDirLayout
                      StoreDirLayout
storeDirLayout
                      (JobControl IO (UnitId, Either BuildFailure BuildResult)
-> Maybe SemaphoreName
forall (m :: * -> *) a. JobControl m a -> Maybe SemaphoreName
jobControlSemaphore JobControl IO (UnitId, Either BuildFailure BuildResult)
jobControl)
                      BuildTimeSettings
buildSettings
                      AsyncFetchMap
downloadMap
                      Lock
registerLock
                      Lock
cacheLock
                      ElaboratedSharedConfig
sharedPackageConfig
                      ElaboratedInstallPlan
installPlan
                      GenericReadyPackage ElaboratedConfiguredPackage
pkg
                      BuildStatus
pkgBuildStatus
    where
      keepGoing :: Bool
keepGoing = Bool
buildSettingKeepGoing
      withRepoCtx :: (RepoContext -> IO a) -> IO a
withRepoCtx =
        Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext
          Verbosity
verbosity
          BuildTimeSettings
buildSettings
      packageDBsToUse :: [PackageDBCWD]
packageDBsToUse =
        -- all the package dbs we may need to create
        (Set PackageDBCWD -> [PackageDBCWD]
forall a. Set a -> [a]
Set.toList (Set PackageDBCWD -> [PackageDBCWD])
-> ([PackageDBCWD] -> Set PackageDBCWD)
-> [PackageDBCWD]
-> [PackageDBCWD]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PackageDBCWD] -> Set PackageDBCWD
forall a. Ord a => [a] -> Set a
Set.fromList)
          [ PackageDBCWD
pkgdb
          | InstallPlan.Configured ElaboratedConfiguredPackage
elab <- ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
installPlan
          , PackageDBCWD
pkgdb <-
              [[PackageDBCWD]] -> [PackageDBCWD]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ ElaboratedConfiguredPackage -> [PackageDBCWD]
elabBuildPackageDBStack ElaboratedConfiguredPackage
elab
                , ElaboratedConfiguredPackage -> [PackageDBCWD]
elabRegisterPackageDBStack ElaboratedConfiguredPackage
elab
                , ElaboratedConfiguredPackage -> [PackageDBCWD]
elabSetupPackageDBStack ElaboratedConfiguredPackage
elab
                ]
          ]

      offlineError :: BuildOutcomes
      offlineError :: BuildOutcomes
offlineError = [(UnitId, Either BuildFailure BuildResult)] -> BuildOutcomes
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UnitId, Either BuildFailure BuildResult)] -> BuildOutcomes)
-> ([ElaboratedConfiguredPackage]
    -> [(UnitId, Either BuildFailure BuildResult)])
-> [ElaboratedConfiguredPackage]
-> BuildOutcomes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ElaboratedConfiguredPackage
 -> (UnitId, Either BuildFailure BuildResult))
-> [ElaboratedConfiguredPackage]
-> [(UnitId, Either BuildFailure BuildResult)]
forall a b. (a -> b) -> [a] -> [b]
map ElaboratedConfiguredPackage
-> (UnitId, Either BuildFailure BuildResult)
makeBuildOutcome ([ElaboratedConfiguredPackage] -> BuildOutcomes)
-> [ElaboratedConfiguredPackage] -> BuildOutcomes
forall a b. (a -> b) -> a -> b
$ [ElaboratedConfiguredPackage]
packagesToDownload
        where
          makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome)
          makeBuildOutcome :: ElaboratedConfiguredPackage
-> (UnitId, Either BuildFailure BuildResult)
makeBuildOutcome
            ElaboratedConfiguredPackage
              { UnitId
elabUnitId :: UnitId
elabUnitId :: ElaboratedConfiguredPackage -> UnitId
elabUnitId
              , elabPkgSourceId :: ElaboratedConfiguredPackage -> PackageIdentifier
elabPkgSourceId = PackageIdentifier{PackageName
pkgName :: PackageName
pkgName :: PackageIdentifier -> PackageName
pkgName, Version
pkgVersion :: Version
pkgVersion :: PackageIdentifier -> Version
pkgVersion}
              } =
              ( UnitId
elabUnitId
              , BuildFailure -> Either BuildFailure BuildResult
forall a b. a -> Either a b
Left
                  ( BuildFailure
                      { buildFailureLogFile :: Maybe FilePath
buildFailureLogFile = Maybe FilePath
forall a. Maybe a
Nothing
                      , buildFailureReason :: BuildFailureReason
buildFailureReason = FilePath -> BuildFailureReason
GracefulFailure (FilePath -> BuildFailureReason) -> FilePath -> BuildFailureReason
forall a b. (a -> b) -> a -> b
$ PackageName -> Version -> FilePath
makeError PackageName
pkgName Version
pkgVersion
                      }
                  )
              )
          makeError :: PackageName -> Version -> String
          makeError :: PackageName -> Version -> FilePath
makeError PackageName
n Version
v =
            FilePath
"--offline was specified, hence refusing to download the package: "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
unPackageName PackageName
n
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" version "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Doc -> FilePath
Disp.render (Version -> Doc
forall a. Pretty a => a -> Doc
pretty Version
v)

      packagesToDownload :: [ElaboratedConfiguredPackage]
      packagesToDownload :: [ElaboratedConfiguredPackage]
packagesToDownload =
        [ ElaboratedConfiguredPackage
elab | InstallPlan.Configured ElaboratedConfiguredPackage
elab <- ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.reverseTopologicalOrder ElaboratedInstallPlan
installPlan, UnresolvedPkgLoc -> Bool
forall a. PackageLocation a -> Bool
isRemote (UnresolvedPkgLoc -> Bool) -> UnresolvedPkgLoc -> Bool
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> UnresolvedPkgLoc
elabPkgSourceLocation ElaboratedConfiguredPackage
elab
        ]
        where
          isRemote :: PackageLocation a -> Bool
          isRemote :: forall a. PackageLocation a -> Bool
isRemote (RemoteTarballPackage URI
_ a
_) = Bool
True
          isRemote (RepoTarballPackage{}) = Bool
True
          isRemote (RemoteSourceRepoPackage SourceRepoMaybe
_ a
_) = Bool
True
          isRemote PackageLocation a
_ = Bool
False

-- | Create a package DB if it does not currently exist. Note that this action
-- is /not/ safe to run concurrently.
createPackageDBIfMissing
  :: Verbosity
  -> Compiler
  -> ProgramDb
  -> PackageDBCWD
  -> IO ()
createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb -> PackageDBCWD -> IO ()
createPackageDBIfMissing
  Verbosity
verbosity
  Compiler
compiler
  ProgramDb
progdb
  (SpecificPackageDB FilePath
dbPath) = do
    Bool
exists <- FilePath -> IO Bool
Cabal.doesPackageDBExist FilePath
dbPath
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (FilePath -> FilePath
takeDirectory FilePath
dbPath)
      Verbosity -> Compiler -> ProgramDb -> Bool -> FilePath -> IO ()
Cabal.createPackageDB Verbosity
verbosity Compiler
compiler ProgramDb
progdb Bool
False FilePath
dbPath
createPackageDBIfMissing Verbosity
_ Compiler
_ ProgramDb
_ PackageDBCWD
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Given all the context and resources, (re)build an individual package.
rebuildTarget
  :: Verbosity
  -> DistDirLayout
  -> StoreDirLayout
  -> Maybe SemaphoreName
  -> BuildTimeSettings
  -> AsyncFetchMap
  -> Lock
  -> Lock
  -> ElaboratedSharedConfig
  -> ElaboratedInstallPlan
  -> ElaboratedReadyPackage
  -> BuildStatus
  -> IO BuildResult
rebuildTarget :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> Maybe SemaphoreName
-> BuildTimeSettings
-> AsyncFetchMap
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> BuildStatus
-> IO BuildResult
rebuildTarget
  Verbosity
verbosity
  distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{DistDirParams -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildDirectory}
  StoreDirLayout
storeDirLayout
  Maybe SemaphoreName
semaphoreName
  BuildTimeSettings
buildSettings
  AsyncFetchMap
downloadMap
  Lock
registerLock
  Lock
cacheLock
  ElaboratedSharedConfig
sharedPackageConfig
  ElaboratedInstallPlan
plan
  rpkg :: GenericReadyPackage ElaboratedConfiguredPackage
rpkg@(ReadyPackage ElaboratedConfiguredPackage
pkg)
  BuildStatus
pkgBuildStatus
    -- Technically, doing the --only-download filtering only in this function is
    -- not perfect. We could also prune the plan at an earlier stage, like it's
    -- done with --only-dependencies. But...
    --   * the benefit would be minimal (practically just avoiding to print the
    --     "requires build" parts of the plan)
    --   * we currently don't have easy access to the BuildStatus of packages
    --     in the pruning phase
    --   * we still have to check it here to avoid performing successive phases
    | BuildTimeSettings -> Bool
buildSettingOnlyDownload BuildTimeSettings
buildSettings = do
        case BuildStatus
pkgBuildStatus of
          BuildStatus
BuildStatusDownload ->
            IO DownloadedSourceLocation -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO DownloadedSourceLocation -> IO ())
-> IO DownloadedSourceLocation -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity
-> AsyncFetchMap
-> ElaboratedConfiguredPackage
-> IO DownloadedSourceLocation
waitAsyncPackageDownload Verbosity
verbosity AsyncFetchMap
downloadMap ElaboratedConfiguredPackage
pkg
          BuildStatus
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        BuildResult -> IO BuildResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildResult -> IO BuildResult) -> BuildResult -> IO BuildResult
forall a b. (a -> b) -> a -> b
$ DocsResult -> TestsResult -> Maybe FilePath -> BuildResult
BuildResult DocsResult
DocsNotTried TestsResult
TestsNotTried Maybe FilePath
forall a. Maybe a
Nothing
    | Bool
otherwise =
        -- We rely on the 'BuildStatus' to decide which phase to start from:
        case BuildStatus
pkgBuildStatus of
          BuildStatus
BuildStatusDownload -> IO BuildResult
downloadPhase
          BuildStatusUnpack FilePath
tarball -> FilePath -> IO BuildResult
unpackTarballPhase FilePath
tarball
          BuildStatusRebuild FilePath
srcdir BuildStatusRebuild
status -> BuildStatusRebuild -> SymbolicPath CWD ('Dir Pkg) -> IO BuildResult
rebuildPhase BuildStatusRebuild
status (FilePath -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath FilePath
srcdir)
          -- TODO: perhaps re-nest the types to make these impossible
          BuildStatusPreExisting{} -> IO BuildResult
forall {a}. a
unexpectedState
          BuildStatusInstalled{} -> IO BuildResult
forall {a}. a
unexpectedState
          BuildStatusUpToDate{} -> IO BuildResult
forall {a}. a
unexpectedState
    where
      unexpectedState :: a
unexpectedState = FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"rebuildTarget: unexpected package status"

      downloadPhase :: IO BuildResult
      downloadPhase :: IO BuildResult
downloadPhase = do
        DownloadedSourceLocation
downsrcloc <-
          (SomeException -> BuildFailureReason)
-> IO DownloadedSourceLocation -> IO DownloadedSourceLocation
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
DownloadFailed (IO DownloadedSourceLocation -> IO DownloadedSourceLocation)
-> IO DownloadedSourceLocation -> IO DownloadedSourceLocation
forall a b. (a -> b) -> a -> b
$
            Verbosity
-> AsyncFetchMap
-> ElaboratedConfiguredPackage
-> IO DownloadedSourceLocation
waitAsyncPackageDownload Verbosity
verbosity AsyncFetchMap
downloadMap ElaboratedConfiguredPackage
pkg
        case DownloadedSourceLocation
downsrcloc of
          DownloadedTarball FilePath
tarball -> FilePath -> IO BuildResult
unpackTarballPhase FilePath
tarball
      -- TODO: [nice to have] git/darcs repos etc

      unpackTarballPhase :: FilePath -> IO BuildResult
      unpackTarballPhase :: FilePath -> IO BuildResult
unpackTarballPhase FilePath
tarball =
        Verbosity
-> DistDirLayout
-> FilePath
-> PackageIdentifier
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
-> (SymbolicPath CWD ('Dir Pkg)
    -> SymbolicPath Pkg ('Dir Dist) -> IO BuildResult)
-> IO BuildResult
forall a.
Verbosity
-> DistDirLayout
-> FilePath
-> PackageIdentifier
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
-> (SymbolicPath CWD ('Dir Pkg)
    -> SymbolicPath Pkg ('Dir Dist) -> IO a)
-> IO a
withTarballLocalDirectory
          Verbosity
verbosity
          DistDirLayout
distDirLayout
          FilePath
tarball
          (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg)
          (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
sharedPackageConfig ElaboratedConfiguredPackage
pkg)
          (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg)
          (ElaboratedConfiguredPackage -> Maybe CabalFileText
elabPkgDescriptionOverride ElaboratedConfiguredPackage
pkg)
          ((SymbolicPath CWD ('Dir Pkg)
  -> SymbolicPath Pkg ('Dir Dist) -> IO BuildResult)
 -> IO BuildResult)
-> (SymbolicPath CWD ('Dir Pkg)
    -> SymbolicPath Pkg ('Dir Dist) -> IO BuildResult)
-> IO BuildResult
forall a b. (a -> b) -> a -> b
$ case ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg of
            BuildStyle
BuildAndInstall -> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist) -> IO BuildResult
buildAndInstall
            BuildInplaceOnly{} -> BuildStatusRebuild
-> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> IO BuildResult
buildInplace BuildStatusRebuild
buildStatus
              where
                buildStatus :: BuildStatusRebuild
buildStatus = MonitorChangedReason () -> BuildStatusRebuild
BuildStatusConfigure MonitorChangedReason ()
forall a. MonitorChangedReason a
MonitorFirstRun

      -- Note that this really is rebuild, not build. It can only happen for
      -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
      -- would only start from download or unpack phases.
      --
      rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> IO BuildResult
      rebuildPhase :: BuildStatusRebuild -> SymbolicPath CWD ('Dir Pkg) -> IO BuildResult
rebuildPhase BuildStatusRebuild
buildStatus SymbolicPath CWD ('Dir Pkg)
srcdir =
        Bool
-> (BuildStatusRebuild
    -> SymbolicPath CWD ('Dir Pkg)
    -> SymbolicPath Pkg ('Dir Dist)
    -> IO BuildResult)
-> BuildStatusRebuild
-> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> IO BuildResult
forall a. HasCallStack => Bool -> a -> a
assert
          (BuildStyle -> Bool
isInplaceBuildStyle (BuildStyle -> Bool) -> BuildStyle -> Bool
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg)
          BuildStatusRebuild
-> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> IO BuildResult
buildInplace
          BuildStatusRebuild
buildStatus
          SymbolicPath CWD ('Dir Pkg)
srcdir
          SymbolicPath Pkg ('Dir Dist)
forall {from} {to :: FileOrDir}. SymbolicPath from to
builddir
        where
          distdir :: FilePath
distdir = DistDirParams -> FilePath
distBuildDirectory (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
sharedPackageConfig ElaboratedConfiguredPackage
pkg)
          builddir :: SymbolicPath from to
builddir =
            FilePath -> SymbolicPath from to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath (FilePath -> SymbolicPath from to)
-> FilePath -> SymbolicPath from to
forall a b. (a -> b) -> a -> b
$
              FilePath -> FilePath -> FilePath
makeRelative (FilePath -> FilePath
normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ SymbolicPath CWD ('Dir Pkg) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath SymbolicPath CWD ('Dir Pkg)
srcdir) FilePath
distdir
      -- TODO: [nice to have] ^^ do this relative stuff better

      buildAndInstall :: SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult
      buildAndInstall :: SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist) -> IO BuildResult
buildAndInstall SymbolicPath CWD ('Dir Pkg)
srcdir SymbolicPath Pkg ('Dir Dist)
builddir =
        Verbosity
-> DistDirLayout
-> StoreDirLayout
-> Maybe SemaphoreName
-> BuildTimeSettings
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> IO BuildResult
buildAndInstallUnpackedPackage
          Verbosity
verbosity
          DistDirLayout
distDirLayout
          StoreDirLayout
storeDirLayout
          Maybe SemaphoreName
semaphoreName
          BuildTimeSettings
buildSettings
          Lock
registerLock
          Lock
cacheLock
          ElaboratedSharedConfig
sharedPackageConfig
          ElaboratedInstallPlan
plan
          GenericReadyPackage ElaboratedConfiguredPackage
rpkg
          SymbolicPath CWD ('Dir Pkg)
srcdir
          SymbolicPath Pkg ('Dir Dist)
builddir

      buildInplace :: BuildStatusRebuild -> SymbolicPath CWD (Dir Pkg) -> SymbolicPath Pkg (Dir Dist) -> IO BuildResult
      buildInplace :: BuildStatusRebuild
-> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> IO BuildResult
buildInplace BuildStatusRebuild
buildStatus SymbolicPath CWD ('Dir Pkg)
srcdir SymbolicPath Pkg ('Dir Dist)
builddir =
        -- TODO: [nice to have] use a relative build dir rather than absolute
        Verbosity
-> DistDirLayout
-> Maybe SemaphoreName
-> BuildTimeSettings
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> BuildStatusRebuild
-> SymbolicPath CWD ('Dir Pkg)
-> SymbolicPath Pkg ('Dir Dist)
-> IO BuildResult
buildInplaceUnpackedPackage
          Verbosity
verbosity
          DistDirLayout
distDirLayout
          Maybe SemaphoreName
semaphoreName
          BuildTimeSettings
buildSettings
          Lock
registerLock
          Lock
cacheLock
          ElaboratedSharedConfig
sharedPackageConfig
          ElaboratedInstallPlan
plan
          GenericReadyPackage ElaboratedConfiguredPackage
rpkg
          BuildStatusRebuild
buildStatus
          SymbolicPath CWD ('Dir Pkg)
srcdir
          SymbolicPath Pkg ('Dir Dist)
builddir

-- TODO: [nice to have] do we need to use a with-style for the temp
-- files for downloading http packages, or are we going to cache them
-- persistently?

-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the
-- packages we have to download and fork off an async action to download them.
-- We download them in dependency order so that the one's we'll need
-- first are the ones we will start downloading first.
--
-- The body action is passed a map from those packages (identified by their
-- location) to a completion var for that package. So the body action should
-- lookup the location and use 'waitAsyncPackageDownload' to get the result.
asyncDownloadPackages
  :: Verbosity
  -> ((RepoContext -> IO a) -> IO a)
  -> ElaboratedInstallPlan
  -> BuildStatusMap
  -> (AsyncFetchMap -> IO a)
  -> IO a
asyncDownloadPackages :: forall a.
Verbosity
-> ((RepoContext -> IO a) -> IO a)
-> ElaboratedInstallPlan
-> BuildStatusMap
-> (AsyncFetchMap -> IO a)
-> IO a
asyncDownloadPackages Verbosity
verbosity (RepoContext -> IO a) -> IO a
withRepoCtx ElaboratedInstallPlan
installPlan BuildStatusMap
pkgsBuildStatus AsyncFetchMap -> IO a
body
  | [UnresolvedPkgLoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedPkgLoc]
pkgsToDownload = AsyncFetchMap -> IO a
body AsyncFetchMap
forall k a. Map k a
Map.empty
  | Bool
otherwise = (RepoContext -> IO a) -> IO a
withRepoCtx ((RepoContext -> IO a) -> IO a) -> (RepoContext -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \RepoContext
repoctx ->
      Verbosity
-> RepoContext
-> [UnresolvedPkgLoc]
-> (AsyncFetchMap -> IO a)
-> IO a
forall a.
Verbosity
-> RepoContext
-> [UnresolvedPkgLoc]
-> (AsyncFetchMap -> IO a)
-> IO a
asyncFetchPackages
        Verbosity
verbosity
        RepoContext
repoctx
        [UnresolvedPkgLoc]
pkgsToDownload
        AsyncFetchMap -> IO a
body
  where
    pkgsToDownload :: [PackageLocation (Maybe FilePath)]
    pkgsToDownload :: [UnresolvedPkgLoc]
pkgsToDownload =
      [UnresolvedPkgLoc] -> [UnresolvedPkgLoc]
forall a. Ord a => [a] -> [a]
ordNub ([UnresolvedPkgLoc] -> [UnresolvedPkgLoc])
-> [UnresolvedPkgLoc] -> [UnresolvedPkgLoc]
forall a b. (a -> b) -> a -> b
$
        [ ElaboratedConfiguredPackage -> UnresolvedPkgLoc
elabPkgSourceLocation ElaboratedConfiguredPackage
elab
        | InstallPlan.Configured ElaboratedConfiguredPackage
elab <-
            ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.reverseTopologicalOrder ElaboratedInstallPlan
installPlan
        , let uid :: UnitId
uid = ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
elab
              pkgBuildStatus :: BuildStatus
pkgBuildStatus = BuildStatus -> UnitId -> BuildStatusMap -> BuildStatus
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (FilePath -> BuildStatus
forall a. HasCallStack => FilePath -> a
error FilePath
"asyncDownloadPackages") UnitId
uid BuildStatusMap
pkgsBuildStatus
        , BuildStatus
BuildStatusDownload <- [BuildStatus
pkgBuildStatus]
        ]

-- | Check if a package needs downloading, and if so expect to find a download
-- in progress in the given 'AsyncFetchMap' and wait on it to finish.
waitAsyncPackageDownload
  :: Verbosity
  -> AsyncFetchMap
  -> ElaboratedConfiguredPackage
  -> IO DownloadedSourceLocation
waitAsyncPackageDownload :: Verbosity
-> AsyncFetchMap
-> ElaboratedConfiguredPackage
-> IO DownloadedSourceLocation
waitAsyncPackageDownload Verbosity
verbosity AsyncFetchMap
downloadMap ElaboratedConfiguredPackage
elab = do
  ResolvedPkgLoc
pkgloc <-
    Verbosity -> AsyncFetchMap -> UnresolvedPkgLoc -> IO ResolvedPkgLoc
waitAsyncFetchPackage
      Verbosity
verbosity
      AsyncFetchMap
downloadMap
      (ElaboratedConfiguredPackage -> UnresolvedPkgLoc
elabPkgSourceLocation ElaboratedConfiguredPackage
elab)
  case ResolvedPkgLoc -> Maybe DownloadedSourceLocation
downloadedSourceLocation ResolvedPkgLoc
pkgloc of
    Just DownloadedSourceLocation
loc -> DownloadedSourceLocation -> IO DownloadedSourceLocation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DownloadedSourceLocation
loc
    Maybe DownloadedSourceLocation
Nothing -> FilePath -> IO DownloadedSourceLocation
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"waitAsyncPackageDownload: unexpected source location"

data DownloadedSourceLocation = DownloadedTarball FilePath

-- TODO: [nice to have] git/darcs repos etc

downloadedSourceLocation
  :: PackageLocation FilePath
  -> Maybe DownloadedSourceLocation
downloadedSourceLocation :: ResolvedPkgLoc -> Maybe DownloadedSourceLocation
downloadedSourceLocation ResolvedPkgLoc
pkgloc =
  case ResolvedPkgLoc
pkgloc of
    RemoteTarballPackage URI
_ FilePath
tarball -> DownloadedSourceLocation -> Maybe DownloadedSourceLocation
forall a. a -> Maybe a
Just (FilePath -> DownloadedSourceLocation
DownloadedTarball FilePath
tarball)
    RepoTarballPackage Repo
_ PackageIdentifier
_ FilePath
tarball -> DownloadedSourceLocation -> Maybe DownloadedSourceLocation
forall a. a -> Maybe a
Just (FilePath -> DownloadedSourceLocation
DownloadedTarball FilePath
tarball)
    ResolvedPkgLoc
_ -> Maybe DownloadedSourceLocation
forall a. Maybe a
Nothing

-- | Ensure that the package is unpacked in an appropriate directory, either
-- a temporary one or a persistent one under the shared dist directory.
withTarballLocalDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
  -> DistDirParams
  -> BuildStyle
  -> Maybe CabalFileText
  -> ( SymbolicPath CWD (Dir Pkg) -- Source directory
       -> SymbolicPath Pkg (Dir Dist) -- Build directory
       -> IO a
     )
  -> IO a
withTarballLocalDirectory :: forall a.
Verbosity
-> DistDirLayout
-> FilePath
-> PackageIdentifier
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
-> (SymbolicPath CWD ('Dir Pkg)
    -> SymbolicPath Pkg ('Dir Dist) -> IO a)
-> IO a
withTarballLocalDirectory
  Verbosity
verbosity
  distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{FilePath
Maybe FilePath
FilePath -> FilePath
CompilerId -> PackageDBCWD
PackageIdentifier -> FilePath
DistDirParams -> FilePath
DistDirParams -> FilePath -> FilePath
distProjectRootDirectory :: DistDirLayout -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distDirectory :: DistDirLayout -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildRootDirectory :: DistDirLayout -> FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distUnpackedSrcDirectory :: DistDirLayout -> PackageIdentifier -> FilePath
distUnpackedSrcRootDirectory :: DistDirLayout -> FilePath
distProjectCacheFile :: DistDirLayout -> FilePath -> FilePath
distProjectCacheDirectory :: DistDirLayout -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distSdistFile :: DistDirLayout -> PackageIdentifier -> FilePath
distSdistDirectory :: DistDirLayout -> FilePath
distTempDirectory :: DistDirLayout -> FilePath
distBinDirectory :: DistDirLayout -> FilePath
distPackageDB :: DistDirLayout -> CompilerId -> PackageDBCWD
distHaddockOutputDir :: DistDirLayout -> Maybe FilePath
distProjectRootDirectory :: FilePath
distProjectFile :: FilePath -> FilePath
distDirectory :: FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildRootDirectory :: FilePath
distDownloadSrcDirectory :: FilePath
distUnpackedSrcDirectory :: PackageIdentifier -> FilePath
distUnpackedSrcRootDirectory :: FilePath
distProjectCacheFile :: FilePath -> FilePath
distProjectCacheDirectory :: FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distSdistFile :: PackageIdentifier -> FilePath
distSdistDirectory :: FilePath
distTempDirectory :: FilePath
distBinDirectory :: FilePath
distPackageDB :: CompilerId -> PackageDBCWD
distHaddockOutputDir :: Maybe FilePath
..}
  FilePath
tarball
  PackageIdentifier
pkgid
  DistDirParams
dparams
  BuildStyle
buildstyle
  Maybe CabalFileText
pkgTextOverride
  SymbolicPath CWD ('Dir Pkg) -> SymbolicPath Pkg ('Dir Dist) -> IO a
buildPkg =
    case BuildStyle
buildstyle of
      -- In this case we make a temp dir (e.g. tmp/src2345/), unpack
      -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for
      -- compatibility we put the dist dir within it
      -- (i.e. tmp/src2345/foo-1.0/dist/).
      --
      -- Unfortunately, a few custom Setup.hs scripts do not respect
      -- the --builddir flag and always look for it at ./dist/ so
      -- this way we avoid breaking those packages
      BuildStyle
BuildAndInstall ->
        let tmpdir :: FilePath
tmpdir = FilePath
distTempDirectory
            builddir :: SymbolicPath from to
builddir = RelativePath from to -> SymbolicPath from to
forall from (to :: FileOrDir).
RelativePath from to -> SymbolicPath from to
relativeSymbolicPath (RelativePath from to -> SymbolicPath from to)
-> RelativePath from to -> SymbolicPath from to
forall a b. (a -> b) -> a -> b
$ FilePath -> RelativePath from to
forall from (to :: FileOrDir).
HasCallStack =>
FilePath -> RelativePath from to
makeRelativePathEx FilePath
"dist"
         in Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tmpdir FilePath
"src" ((FilePath -> IO a) -> IO a) -> (FilePath -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \FilePath
unpackdir -> do
              let srcdir :: SymbolicPath from to
srcdir = FilePath -> SymbolicPath from to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath (FilePath -> SymbolicPath from to)
-> FilePath -> SymbolicPath from to
forall a b. (a -> b) -> a -> b
$ FilePath
unpackdir FilePath -> FilePath -> FilePath
</> PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
              Verbosity
-> FilePath
-> FilePath
-> PackageIdentifier
-> Maybe CabalFileText
-> IO ()
unpackPackageTarball
                Verbosity
verbosity
                FilePath
tarball
                FilePath
unpackdir
                PackageIdentifier
pkgid
                Maybe CabalFileText
pkgTextOverride
              SymbolicPath CWD ('Dir Pkg) -> SymbolicPath Pkg ('Dir Dist) -> IO a
buildPkg SymbolicPath CWD ('Dir Pkg)
forall {from} {to :: FileOrDir}. SymbolicPath from to
srcdir SymbolicPath Pkg ('Dir Dist)
forall {from} {to :: FileOrDir}. SymbolicPath from to
builddir

      -- In this case we make sure the tarball has been unpacked to the
      -- appropriate location under the shared dist dir, and then build it
      -- inplace there
      BuildInplaceOnly{} -> do
        let srcrootdir :: FilePath
srcrootdir = FilePath
distUnpackedSrcRootDirectory
            srcdir :: FilePath
srcdir = PackageIdentifier -> FilePath
distUnpackedSrcDirectory PackageIdentifier
pkgid
            builddir :: SymbolicPath from to
builddir =
              FilePath -> SymbolicPath from to
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath (FilePath -> SymbolicPath from to)
-> FilePath -> SymbolicPath from to
forall a b. (a -> b) -> a -> b
$
                FilePath -> FilePath -> FilePath
makeRelative (FilePath -> FilePath
normalise FilePath
srcdir) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
                  DistDirParams -> FilePath
distBuildDirectory DistDirParams
dparams
        -- TODO: [nice to have] ^^ do this relative stuff better
        Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
srcdir
        -- TODO: [nice to have] use a proper file monitor rather
        -- than this dir exists test
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
srcrootdir
          Verbosity
-> FilePath
-> FilePath
-> PackageIdentifier
-> Maybe CabalFileText
-> IO ()
unpackPackageTarball
            Verbosity
verbosity
            FilePath
tarball
            FilePath
srcrootdir
            PackageIdentifier
pkgid
            Maybe CabalFileText
pkgTextOverride
          Verbosity
-> DistDirLayout
-> FilePath
-> PackageIdentifier
-> DistDirParams
-> IO ()
moveTarballShippedDistDirectory
            Verbosity
verbosity
            DistDirLayout
distDirLayout
            FilePath
srcrootdir
            PackageIdentifier
pkgid
            DistDirParams
dparams
        SymbolicPath CWD ('Dir Pkg) -> SymbolicPath Pkg ('Dir Dist) -> IO a
buildPkg (FilePath -> SymbolicPath CWD ('Dir Pkg)
forall from (to :: FileOrDir). FilePath -> SymbolicPath from to
makeSymbolicPath FilePath
srcdir) SymbolicPath Pkg ('Dir Dist)
forall {from} {to :: FileOrDir}. SymbolicPath from to
builddir

unpackPackageTarball
  :: Verbosity
  -> FilePath
  -> FilePath
  -> PackageId
  -> Maybe CabalFileText
  -> IO ()
unpackPackageTarball :: Verbosity
-> FilePath
-> FilePath
-> PackageIdentifier
-> Maybe CabalFileText
-> IO ()
unpackPackageTarball Verbosity
verbosity FilePath
tarball FilePath
parentdir PackageIdentifier
pkgid Maybe CabalFileText
pkgTextOverride =
  -- TODO: [nice to have] switch to tar package and catch tar exceptions
  (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
UnpackFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Unpack the tarball
    --
    Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Extracting " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tarball FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
parentdir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"..."
    FilePath -> FilePath -> FilePath -> IO ()
Tar.extractTarGzFile FilePath
parentdir FilePath
pkgsubdir FilePath
tarball

    -- Sanity check
    --
    Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
cabalFile
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> CabalInstallException
CabalFileNotFound FilePath
cabalFile

    -- Overwrite the .cabal with the one from the index, when appropriate
    --
    case Maybe CabalFileText
pkgTextOverride of
      Maybe CabalFileText
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just CabalFileText
pkgtxt -> do
        Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"Updating "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageName
pkgname FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" with the latest revision from the index."
        FilePath -> CabalFileText -> IO ()
writeFileAtomic FilePath
cabalFile CabalFileText
pkgtxt
  where
    cabalFile :: FilePath
    cabalFile :: FilePath
cabalFile =
      FilePath
parentdir
        FilePath -> FilePath -> FilePath
</> FilePath
pkgsubdir
        FilePath -> FilePath -> FilePath
</> PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageName
pkgname
        FilePath -> FilePath -> FilePath
<.> FilePath
"cabal"
    pkgsubdir :: FilePath
pkgsubdir = PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid
    pkgname :: PackageName
pkgname = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid

-- | This is a bit of a hacky workaround. A number of packages ship
-- pre-processed .hs files in a dist directory inside the tarball. We don't
-- use the standard 'dist' location so unless we move this dist dir to the
-- right place then we'll miss the shipped pre-processed files. This hacky
-- approach to shipped pre-processed files ought to be replaced by a proper
-- system, though we'll still need to keep this hack for older packages.
moveTarballShippedDistDirectory
  :: Verbosity
  -> DistDirLayout
  -> FilePath
  -> PackageId
  -> DistDirParams
  -> IO ()
moveTarballShippedDistDirectory :: Verbosity
-> DistDirLayout
-> FilePath
-> PackageIdentifier
-> DistDirParams
-> IO ()
moveTarballShippedDistDirectory
  Verbosity
verbosity
  DistDirLayout{DistDirParams -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildDirectory}
  FilePath
parentdir
  PackageIdentifier
pkgid
  DistDirParams
dparams = do
    Bool
distDirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
tarballDistDir
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
distDirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"Moving '"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
tarballDistDir
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' to '"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetDistDir
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'"
      -- TODO: [nice to have] or perhaps better to copy, and use a file monitor
      FilePath -> FilePath -> IO ()
renameDirectory FilePath
tarballDistDir FilePath
targetDistDir
    where
      tarballDistDir :: FilePath
tarballDistDir = FilePath
parentdir FilePath -> FilePath -> FilePath
</> PackageIdentifier -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageIdentifier
pkgid FilePath -> FilePath -> FilePath
</> FilePath
"dist"
      targetDistDir :: FilePath
targetDistDir = DistDirParams -> FilePath
distBuildDirectory DistDirParams
dparams