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

-- |
--
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.PackageHash (renderPackageHashInputs)
import           Distribution.Client.RebuildMonad
import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning
import           Distribution.Client.ProjectPlanning.Types
import           Distribution.Client.ProjectBuilding.Types
import           Distribution.Client.Store

import           Distribution.Client.Types
                   hiding (BuildOutcomes, BuildOutcome,
                           BuildResult(..), BuildFailure(..))
import           Distribution.Client.InstallPlan
                   ( GenericInstallPlan, GenericPlanPackage, IsUnit )
import qualified Distribution.Client.InstallPlan as InstallPlan
import           Distribution.Client.DistDirLayout
import           Distribution.Client.FileMonitor
import           Distribution.Client.SetupWrapper
import           Distribution.Client.JobControl
import           Distribution.Client.FetchUtils
import           Distribution.Client.GlobalFlags (RepoContext)
import qualified Distribution.Client.Tar as Tar
import           Distribution.Client.Setup
                   ( filterConfigureFlags, filterHaddockArgs
                   , filterHaddockFlags, filterTestFlags )
import           Distribution.Client.SourceFiles
import           Distribution.Client.SrcDist (allPackageSourceFiles)
import           Distribution.Client.Utils
                   ( ProgressPhase(..), findOpenProgramLocation, progressMessage, removeExistingFile )

import           Distribution.Compat.Lens
import           Distribution.Package
import qualified Distribution.PackageDescription as PD
import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
import           Distribution.Simple.BuildPaths (haddockDirName)
import qualified Distribution.Simple.InstallDirs as InstallDirs
import           Distribution.Types.BuildType
import           Distribution.Types.PackageDescription.Lens (componentModules)
import           Distribution.Simple.Program
import qualified Distribution.Simple.Setup as Cabal
import           Distribution.Simple.Command (CommandUI)
import qualified Distribution.Simple.Register as Cabal
import           Distribution.Simple.LocalBuildInfo
                   ( ComponentName(..), LibraryName(..) )
import           Distribution.Simple.Compiler
                   ( Compiler, compilerId, PackageDB(..) )

import           Distribution.Simple.Utils
import           Distribution.Version
import           Distribution.Compat.Graph (IsNode(..))

import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS.Char8

import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
import System.IO         (IOMode (AppendMode), Handle, withFile)

import Distribution.Compat.Directory (listDirectory)


------------------------------------------------------------------------------
-- * 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
FilePath -> FilePath
PackageId -> FilePath
CompilerId -> PackageDB
DistDirParams -> FilePath
DistDirParams -> FilePath -> FilePath
distPackageDB :: DistDirLayout -> CompilerId -> PackageDB
distBinDirectory :: DistDirLayout -> FilePath
distTempDirectory :: DistDirLayout -> FilePath
distSdistDirectory :: DistDirLayout -> FilePath
distSdistFile :: DistDirLayout -> PackageId -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distProjectCacheDirectory :: DistDirLayout -> FilePath
distProjectCacheFile :: DistDirLayout -> FilePath -> FilePath
distUnpackedSrcRootDirectory :: DistDirLayout -> FilePath
distUnpackedSrcDirectory :: DistDirLayout -> PackageId -> FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distBuildRootDirectory :: DistDirLayout -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distDirectory :: DistDirLayout -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distProjectRootDirectory :: DistDirLayout -> FilePath
distPackageDB :: CompilerId -> PackageDB
distBinDirectory :: FilePath
distTempDirectory :: FilePath
distSdistDirectory :: FilePath
distSdistFile :: PackageId -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distProjectCacheDirectory :: FilePath
distProjectCacheFile :: FilePath -> FilePath
distUnpackedSrcRootDirectory :: FilePath
distUnpackedSrcDirectory :: PackageId -> FilePath
distDownloadSrcDirectory :: FilePath
distBuildRootDirectory :: FilePath
distBuildDirectory :: DistDirParams -> FilePath
distDirectory :: FilePath
distProjectFile :: FilePath -> FilePath
distProjectRootDirectory :: 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 (m :: * -> *) a. Monad m => a -> m a
return BuildStatus
BuildStatusPreExisting

    dryRunPkg (InstallPlan.Installed ElaboratedConfiguredPackage
_pkg) [BuildStatus]
_depsBuildStatus =
      BuildStatus -> IO BuildStatus
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 (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
_ PackageId
_ 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 (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> BuildStatus
BuildStatusUnpack FilePath
tarball)
        BuildStyle
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 (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> BuildStatus
BuildStatusUnpack FilePath
tarball)
      where
        srcdir :: FilePath
        srcdir :: FilePath
srcdir = PackageId -> FilePath
distUnpackedSrcDirectory (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
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 (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 (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 :: (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 (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]
++ PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
pkg) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 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 {
       PackageFileMonitor -> FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),
       PackageFileMonitor
-> FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
       PackageFileMonitor -> FileMonitor () (Maybe InstalledPackageInfo)
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 :: ElaboratedSharedConfig
-> DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor ElaboratedSharedConfig
shared
                      DistDirLayout{DistDirParams -> FilePath -> FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distPackageCacheFile}
                      DistDirParams
dparams =
    PackageFileMonitor :: FileMonitor ElaboratedConfiguredPackage ()
-> FileMonitor (Set ComponentName) BuildResultMisc
-> FileMonitor () (Maybe InstalledPackageInfo)
-> PackageFileMonitor
PackageFileMonitor {
      pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig =
        FileMonitor :: forall a b. FilePath -> (a -> a -> Bool) -> Bool -> FileMonitor a b
FileMonitor {
          fileMonitorCacheFile :: FilePath
fileMonitorCacheFile = DistDirParams -> FilePath -> FilePath
distPackageCacheFile DistDirParams
dparams FilePath
"config",
          fileMonitorKeyValid :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage -> Bool
fileMonitorKeyValid = ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ElaboratedConfiguredPackage
 -> ElaboratedConfiguredPackage -> Bool)
-> (ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage)
-> ElaboratedConfiguredPackage
-> ElaboratedConfiguredPackage
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage
normaliseConfiguredPackage ElaboratedSharedConfig
shared,
          fileMonitorCheckIfOnlyValueChanged :: Bool
fileMonitorCheckIfOnlyValueChanged = Bool
False
        },

      pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild =
        FileMonitor :: forall a b. FilePath -> (a -> a -> Bool) -> Bool -> FileMonitor a b
FileMonitor {
          fileMonitorCacheFile :: FilePath
fileMonitorCacheFile = DistDirParams -> FilePath -> FilePath
distPackageCacheFile DistDirParams
dparams FilePath
"build",
          fileMonitorKeyValid :: Set ComponentName -> Set ComponentName -> Bool
fileMonitorKeyValid  = \Set ComponentName
componentsToBuild Set ComponentName
componentsAlreadyBuilt ->
            Set ComponentName
componentsToBuild Set ComponentName -> Set ComponentName -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set ComponentName
componentsAlreadyBuilt,
          fileMonitorCheckIfOnlyValueChanged :: Bool
fileMonitorCheckIfOnlyValueChanged = Bool
True
        },

      pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg =
        FilePath -> FileMonitor () (Maybe InstalledPackageInfo)
forall a b. Eq a => FilePath -> FileMonitor a b
newFileMonitor (DistDirParams -> FilePath -> FilePath
distPackageCacheFile DistDirParams
dparams FilePath
"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 :: ElaboratedConfiguredPackage
-> (ElaboratedConfiguredPackage, Set ComponentName)
packageFileMonitorKeyValues ElaboratedConfiguredPackage
elab =
    (ElaboratedConfiguredPackage
elab_config, Set ComponentName
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 :: ElaboratedConfiguredPackage
elab_config =
        ElaboratedConfiguredPackage
elab {
            elabBuildTargets :: [ComponentTarget]
elabBuildTargets   = [],
            elabTestTargets :: [ComponentTarget]
elabTestTargets    = [],
            elabBenchTargets :: [ComponentTarget]
elabBenchTargets   = [],
            elabReplTarget :: Maybe ComponentTarget
elabReplTarget     = Maybe ComponentTarget
forall a. Maybe a
Nothing,
            elabHaddockTargets :: [ComponentTarget]
elabHaddockTargets = [],
            elabBuildHaddocks :: Bool
elabBuildHaddocks  = Bool
False,

            elabTestMachineLog :: Maybe PathTemplate
elabTestMachineLog   = Maybe PathTemplate
forall a. Maybe a
Nothing,
            elabTestHumanLog :: Maybe PathTemplate
elabTestHumanLog     = Maybe PathTemplate
forall a. Maybe a
Nothing,
            elabTestShowDetails :: Maybe TestShowDetails
elabTestShowDetails  = Maybe TestShowDetails
forall a. Maybe a
Nothing,
            elabTestKeepTix :: Bool
elabTestKeepTix      = Bool
False,
            elabTestTestOptions :: [PathTemplate]
elabTestTestOptions  = [],
            elabBenchmarkOptions :: [PathTemplate]
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 :: Set ComponentName
buildComponents = ElaboratedConfiguredPackage -> Set ComponentName
elabBuildTargetWholeComponents ElaboratedConfiguredPackage
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
-> ElaboratedConfiguredPackage
-> FilePath
-> [BuildStatus]
-> IO (Either BuildStatusRebuild BuildResult)
checkPackageFileMonitorChanged PackageFileMonitor{FileMonitor () (Maybe InstalledPackageInfo)
FileMonitor (Set ComponentName) BuildResultMisc
FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorReg :: PackageFileMonitor -> FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorBuild :: PackageFileMonitor
-> FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorConfig :: PackageFileMonitor -> FileMonitor ElaboratedConfiguredPackage ()
..}
                               ElaboratedConfiguredPackage
pkg FilePath
srcdir [BuildStatus]
depsBuildStatus = do
    --TODO: [nice to have] some debug-level message about file
    --changes, like rerunIfChanged
    MonitorChanged ElaboratedConfiguredPackage ()
configChanged <- FileMonitor ElaboratedConfiguredPackage ()
-> FilePath
-> ElaboratedConfiguredPackage
-> IO (MonitorChanged ElaboratedConfiguredPackage ())
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b -> FilePath -> a -> IO (MonitorChanged a b)
checkFileMonitorChanged
                       FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig FilePath
srcdir ElaboratedConfiguredPackage
pkgconfig
    case MonitorChanged ElaboratedConfiguredPackage ()
configChanged of
      MonitorChanged MonitorChangedReason ElaboratedConfiguredPackage
monitorReason ->
          Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildStatusRebuild -> Either BuildStatusRebuild BuildResult
forall a b. a -> Either a b
Left (MonitorChangedReason () -> BuildStatusRebuild
BuildStatusConfigure MonitorChangedReason ()
monitorReason'))
        where
          monitorReason' :: MonitorChangedReason ()
monitorReason' = (ElaboratedConfiguredPackage -> ())
-> MonitorChangedReason ElaboratedConfiguredPackage
-> MonitorChangedReason ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> ElaboratedConfiguredPackage -> ()
forall a b. a -> b -> a
const ()) MonitorChangedReason ElaboratedConfiguredPackage
monitorReason

      MonitorUnchanged () [MonitorFilePath]
_
          -- The configChanged here includes the identity of the dependencies,
          -- so depsBuildStatus is just needed for the changes in the content
          -- of dependencies.
        | (BuildStatus -> Bool) -> [BuildStatus] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any BuildStatus -> Bool
buildStatusRequiresBuild [BuildStatus]
depsBuildStatus -> do
            MonitorChanged () (Maybe InstalledPackageInfo)
regChanged <- FileMonitor () (Maybe InstalledPackageInfo)
-> FilePath
-> ()
-> IO (MonitorChanged () (Maybe InstalledPackageInfo))
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b -> FilePath -> a -> IO (MonitorChanged a b)
checkFileMonitorChanged FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg FilePath
srcdir ()
            let mreg :: Maybe (Maybe InstalledPackageInfo)
mreg = MonitorChanged () (Maybe InstalledPackageInfo)
-> Maybe (Maybe InstalledPackageInfo)
forall a b. MonitorChanged a b -> Maybe b
changedToMaybe MonitorChanged () (Maybe InstalledPackageInfo)
regChanged
            Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildStatusRebuild -> Either BuildStatusRebuild BuildResult
forall a b. a -> Either a b
Left (Maybe (Maybe InstalledPackageInfo)
-> BuildReason -> BuildStatusRebuild
BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
mreg BuildReason
BuildReasonDepsRebuilt))

        | Bool
otherwise -> do
            MonitorChanged (Set ComponentName) BuildResultMisc
buildChanged  <- FileMonitor (Set ComponentName) BuildResultMisc
-> FilePath
-> Set ComponentName
-> IO (MonitorChanged (Set ComponentName) BuildResultMisc)
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b -> FilePath -> a -> IO (MonitorChanged a b)
checkFileMonitorChanged
                               FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild FilePath
srcdir Set ComponentName
buildComponents
            MonitorChanged () (Maybe InstalledPackageInfo)
regChanged    <- FileMonitor () (Maybe InstalledPackageInfo)
-> FilePath
-> ()
-> IO (MonitorChanged () (Maybe InstalledPackageInfo))
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b -> FilePath -> a -> IO (MonitorChanged a b)
checkFileMonitorChanged
                               FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg FilePath
srcdir ()
            let mreg :: Maybe (Maybe InstalledPackageInfo)
mreg = MonitorChanged () (Maybe InstalledPackageInfo)
-> Maybe (Maybe InstalledPackageInfo)
forall a b. MonitorChanged a b -> Maybe b
changedToMaybe MonitorChanged () (Maybe InstalledPackageInfo)
regChanged
            case (MonitorChanged (Set ComponentName) BuildResultMisc
buildChanged, MonitorChanged () (Maybe InstalledPackageInfo)
regChanged) of
              (MonitorChanged (MonitoredValueChanged Set ComponentName
prevBuildComponents), MonitorChanged () (Maybe InstalledPackageInfo)
_) ->
                  Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildStatusRebuild -> Either BuildStatusRebuild BuildResult
forall a b. a -> Either a b
Left (Maybe (Maybe InstalledPackageInfo)
-> BuildReason -> BuildStatusRebuild
BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
mreg BuildReason
buildReason))
                where
                  buildReason :: BuildReason
buildReason = Set ComponentName -> BuildReason
BuildReasonExtraTargets Set ComponentName
prevBuildComponents

              (MonitorChanged MonitorChangedReason (Set ComponentName)
monitorReason, MonitorChanged () (Maybe InstalledPackageInfo)
_) ->
                  Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildStatusRebuild -> Either BuildStatusRebuild BuildResult
forall a b. a -> Either a b
Left (Maybe (Maybe InstalledPackageInfo)
-> BuildReason -> BuildStatusRebuild
BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
mreg BuildReason
buildReason))
                where
                  buildReason :: BuildReason
buildReason    = MonitorChangedReason () -> BuildReason
BuildReasonFilesChanged MonitorChangedReason ()
monitorReason'
                  monitorReason' :: MonitorChangedReason ()
monitorReason' = (Set ComponentName -> ())
-> MonitorChangedReason (Set ComponentName)
-> MonitorChangedReason ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Set ComponentName -> ()
forall a b. a -> b -> a
const ()) MonitorChangedReason (Set ComponentName)
monitorReason

              (MonitorUnchanged BuildResultMisc
_ [MonitorFilePath]
_, MonitorChanged MonitorChangedReason ()
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.
                  Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildStatusRebuild -> Either BuildStatusRebuild BuildResult
forall a b. a -> Either a b
Left (Maybe (Maybe InstalledPackageInfo)
-> BuildReason -> BuildStatusRebuild
BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
forall a. Maybe a
Nothing BuildReason
buildReason))
                where
                  buildReason :: BuildReason
buildReason    = MonitorChangedReason () -> BuildReason
BuildReasonFilesChanged MonitorChangedReason ()
monitorReason'
                  monitorReason' :: MonitorChangedReason ()
monitorReason' = (() -> ()) -> MonitorChangedReason () -> MonitorChangedReason ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> () -> ()
forall a b. a -> b -> a
const ()) MonitorChangedReason ()
monitorReason

              (MonitorUnchanged BuildResultMisc
_ [MonitorFilePath]
_, MonitorUnchanged Maybe InstalledPackageInfo
_ [MonitorFilePath]
_)
                | ElaboratedConfiguredPackage -> Bool
pkgHasEphemeralBuildTargets ElaboratedConfiguredPackage
pkg ->
                  Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildStatusRebuild -> Either BuildStatusRebuild BuildResult
forall a b. a -> Either a b
Left (Maybe (Maybe InstalledPackageInfo)
-> BuildReason -> BuildStatusRebuild
BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
mreg BuildReason
buildReason))
                where
                  buildReason :: BuildReason
buildReason = BuildReason
BuildReasonEphemeralTargets

              (MonitorUnchanged BuildResultMisc
buildResult [MonitorFilePath]
_, MonitorUnchanged Maybe InstalledPackageInfo
_ [MonitorFilePath]
_) ->
                  Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either BuildStatusRebuild BuildResult
 -> IO (Either BuildStatusRebuild BuildResult))
-> Either BuildStatusRebuild BuildResult
-> IO (Either BuildStatusRebuild BuildResult)
forall a b. (a -> b) -> a -> b
$ BuildResult -> Either BuildStatusRebuild BuildResult
forall a b. b -> Either a b
Right BuildResult :: DocsResult -> TestsResult -> Maybe FilePath -> BuildResult
BuildResult {
                    buildResultDocs :: DocsResult
buildResultDocs    = DocsResult
docsResult,
                    buildResultTests :: TestsResult
buildResultTests   = TestsResult
testsResult,
                    buildResultLogFile :: Maybe FilePath
buildResultLogFile = Maybe FilePath
forall a. Maybe a
Nothing
                  }
                where
                  (DocsResult
docsResult, TestsResult
testsResult) = BuildResultMisc
buildResult
  where
    (ElaboratedConfiguredPackage
pkgconfig, Set ComponentName
buildComponents) = ElaboratedConfiguredPackage
-> (ElaboratedConfiguredPackage, Set ComponentName)
packageFileMonitorKeyValues ElaboratedConfiguredPackage
pkg
    changedToMaybe :: MonitorChanged a b -> Maybe b
    changedToMaybe :: MonitorChanged a b -> Maybe b
changedToMaybe (MonitorChanged     MonitorChangedReason a
_) = Maybe b
forall a. Maybe a
Nothing
    changedToMaybe (MonitorUnchanged b
x [MonitorFilePath]
_) = b -> Maybe b
forall a. a -> Maybe a
Just b
x


updatePackageConfigFileMonitor :: PackageFileMonitor
                               -> FilePath
                               -> ElaboratedConfiguredPackage
                               -> IO ()
updatePackageConfigFileMonitor :: PackageFileMonitor
-> FilePath -> ElaboratedConfiguredPackage -> IO ()
updatePackageConfigFileMonitor PackageFileMonitor{FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig :: PackageFileMonitor -> FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig}
                               FilePath
srcdir ElaboratedConfiguredPackage
pkg =
    FileMonitor ElaboratedConfiguredPackage ()
-> FilePath
-> Maybe MonitorTimestamp
-> [MonitorFilePath]
-> ElaboratedConfiguredPackage
-> ()
-> IO ()
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b
-> FilePath
-> Maybe MonitorTimestamp
-> [MonitorFilePath]
-> a
-> b
-> IO ()
updateFileMonitor FileMonitor ElaboratedConfiguredPackage ()
pkgFileMonitorConfig FilePath
srcdir Maybe MonitorTimestamp
forall a. Maybe a
Nothing
                      [] ElaboratedConfiguredPackage
pkgconfig ()
  where
    (ElaboratedConfiguredPackage
pkgconfig, Set ComponentName
_buildComponents) = ElaboratedConfiguredPackage
-> (ElaboratedConfiguredPackage, Set ComponentName)
packageFileMonitorKeyValues ElaboratedConfiguredPackage
pkg

updatePackageBuildFileMonitor :: PackageFileMonitor
                              -> FilePath
                              -> MonitorTimestamp
                              -> ElaboratedConfiguredPackage
                              -> BuildStatusRebuild
                              -> [MonitorFilePath]
                              -> BuildResultMisc
                              -> IO ()
updatePackageBuildFileMonitor :: PackageFileMonitor
-> FilePath
-> MonitorTimestamp
-> ElaboratedConfiguredPackage
-> BuildStatusRebuild
-> [MonitorFilePath]
-> BuildResultMisc
-> IO ()
updatePackageBuildFileMonitor PackageFileMonitor{FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild :: PackageFileMonitor
-> FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild}
                              FilePath
srcdir MonitorTimestamp
timestamp ElaboratedConfiguredPackage
pkg BuildStatusRebuild
pkgBuildStatus
                              [MonitorFilePath]
monitors BuildResultMisc
buildResult =
    FileMonitor (Set ComponentName) BuildResultMisc
-> FilePath
-> Maybe MonitorTimestamp
-> [MonitorFilePath]
-> Set ComponentName
-> BuildResultMisc
-> IO ()
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b
-> FilePath
-> Maybe MonitorTimestamp
-> [MonitorFilePath]
-> a
-> b
-> IO ()
updateFileMonitor FileMonitor (Set ComponentName) BuildResultMisc
pkgFileMonitorBuild FilePath
srcdir (MonitorTimestamp -> Maybe MonitorTimestamp
forall a. a -> Maybe a
Just MonitorTimestamp
timestamp)
                      [MonitorFilePath]
monitors Set ComponentName
buildComponents' BuildResultMisc
buildResult
  where
    (ElaboratedConfiguredPackage
_pkgconfig, Set ComponentName
buildComponents) = ElaboratedConfiguredPackage
-> (ElaboratedConfiguredPackage, Set ComponentName)
packageFileMonitorKeyValues ElaboratedConfiguredPackage
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' :: Set ComponentName
buildComponents' =
      case BuildStatusRebuild
pkgBuildStatus of
        BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
_ (BuildReasonExtraTargets Set ComponentName
prevBuildComponents)
          -> Set ComponentName
buildComponents Set ComponentName -> Set ComponentName -> Set ComponentName
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set ComponentName
prevBuildComponents
        BuildStatusRebuild
_ -> Set ComponentName
buildComponents

updatePackageRegFileMonitor :: PackageFileMonitor
                            -> FilePath
                            -> Maybe InstalledPackageInfo
                            -> IO ()
updatePackageRegFileMonitor :: PackageFileMonitor
-> FilePath -> Maybe InstalledPackageInfo -> IO ()
updatePackageRegFileMonitor PackageFileMonitor{FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg :: PackageFileMonitor -> FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg}
                            FilePath
srcdir Maybe InstalledPackageInfo
mipkg =
    FileMonitor () (Maybe InstalledPackageInfo)
-> FilePath
-> Maybe MonitorTimestamp
-> [MonitorFilePath]
-> ()
-> Maybe InstalledPackageInfo
-> IO ()
forall a b.
(Binary a, Structured a, Binary b, Structured b) =>
FileMonitor a b
-> FilePath
-> Maybe MonitorTimestamp
-> [MonitorFilePath]
-> a
-> b
-> IO ()
updateFileMonitor FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg FilePath
srcdir Maybe MonitorTimestamp
forall a. Maybe a
Nothing
                      [] () Maybe InstalledPackageInfo
mipkg

invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor PackageFileMonitor{FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg :: PackageFileMonitor -> FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg} =
    FilePath -> IO ()
removeExistingFile (FileMonitor () (Maybe InstalledPackageInfo) -> FilePath
forall a b. FileMonitor a b -> FilePath
fileMonitorCacheFile FileMonitor () (Maybe InstalledPackageInfo)
pkgFileMonitorReg)


------------------------------------------------------------------------------
-- * 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
               -> DistDirLayout
               -> StoreDirLayout
               -> ElaboratedInstallPlan
               -> ElaboratedSharedConfig
               -> BuildStatusMap
               -> BuildTimeSettings
               -> IO BuildOutcomes
rebuildTargets :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
-> BuildTimeSettings
-> IO BuildOutcomes
rebuildTargets Verbosity
verbosity
               distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{FilePath
FilePath -> FilePath
PackageId -> FilePath
CompilerId -> PackageDB
DistDirParams -> FilePath
DistDirParams -> FilePath -> FilePath
distPackageDB :: CompilerId -> PackageDB
distBinDirectory :: FilePath
distTempDirectory :: FilePath
distSdistDirectory :: FilePath
distSdistFile :: PackageId -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distProjectCacheDirectory :: FilePath
distProjectCacheFile :: FilePath -> FilePath
distUnpackedSrcRootDirectory :: FilePath
distUnpackedSrcDirectory :: PackageId -> FilePath
distDownloadSrcDirectory :: FilePath
distBuildRootDirectory :: FilePath
distBuildDirectory :: DistDirParams -> FilePath
distDirectory :: FilePath
distProjectFile :: FilePath -> FilePath
distProjectRootDirectory :: FilePath
distPackageDB :: DistDirLayout -> CompilerId -> PackageDB
distBinDirectory :: DistDirLayout -> FilePath
distTempDirectory :: DistDirLayout -> FilePath
distSdistDirectory :: DistDirLayout -> FilePath
distSdistFile :: DistDirLayout -> PackageId -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distProjectCacheDirectory :: DistDirLayout -> FilePath
distProjectCacheFile :: DistDirLayout -> FilePath -> FilePath
distUnpackedSrcRootDirectory :: DistDirLayout -> FilePath
distUnpackedSrcDirectory :: DistDirLayout -> PackageId -> FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distBuildRootDirectory :: DistDirLayout -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distDirectory :: DistDirLayout -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distProjectRootDirectory :: DistDirLayout -> 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{
                 Int
buildSettingNumJobs :: BuildTimeSettings -> Int
buildSettingNumJobs :: Int
buildSettingNumJobs,
                 Bool
buildSettingKeepGoing :: BuildTimeSettings -> Bool
buildSettingKeepGoing :: Bool
buildSettingKeepGoing
               } = do

    -- Concurrency control: create the job controller and concurrency limits
    -- for downloading, building and installing.
    JobControl IO (UnitId, Either BuildFailure BuildResult)
jobControl    <- if Bool
isParallelBuild
                       then Int -> IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. WithCallStack (Int -> IO (JobControl IO a))
newParallelJobControl Int
buildSettingNumJobs
                       else IO (JobControl IO (UnitId, Either BuildFailure BuildResult))
forall a. IO (JobControl IO a)
newSerialJobControl
    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 ()
debug 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]
++ if Bool
isParallelBuild
          then FilePath
" in parallel using " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
buildSettingNumJobs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" threads."
          else FilePath
" serially."

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

    -- 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
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)
jobControl 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
. PackageId -> BuildFailureReason
DependentFailed (PackageId -> BuildFailureReason)
-> (ElaboratedConfiguredPackage -> PackageId)
-> ElaboratedConfiguredPackage
-> BuildFailureReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
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 (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 (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
$

        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 in

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


-- | Create a package DB if it does not currently exist. Note that this action
-- is /not/ safe to run concurrently.
--
createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb
                         -> PackageDB -> IO ()
createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb -> PackageDB -> 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
_ PackageDB
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Given all the context and resources, (re)build an individual package.
--
rebuildTarget :: Verbosity
              -> DistDirLayout
              -> StoreDirLayout
              -> BuildTimeSettings
              -> AsyncFetchMap
              -> Lock -> Lock
              -> ElaboratedSharedConfig
              -> ElaboratedInstallPlan
              -> ElaboratedReadyPackage
              -> BuildStatus
              -> IO BuildResult
rebuildTarget :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> BuildTimeSettings
-> AsyncFetchMap
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> BuildStatus
-> IO BuildResult
rebuildTarget Verbosity
verbosity
              distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{DistDirParams -> FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory}
              StoreDirLayout
storeDirLayout
              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 (m :: * -> *) a. Monad m => a -> m a
return ()
        BuildResult -> IO BuildResult
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 -> FilePath -> IO BuildResult
rebuildPhase BuildStatusRebuild
status 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
-> PackageId
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
-> (FilePath -> FilePath -> IO BuildResult)
-> IO BuildResult
forall a.
Verbosity
-> DistDirLayout
-> FilePath
-> PackageId
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
-> (FilePath -> FilePath -> IO a)
-> IO a
withTarballLocalDirectory
          Verbosity
verbosity DistDirLayout
distDirLayout FilePath
tarball
          (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
pkg) (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
sharedPackageConfig ElaboratedConfiguredPackage
pkg)
          (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg)
          (ElaboratedConfiguredPackage -> Maybe CabalFileText
elabPkgDescriptionOverride ElaboratedConfiguredPackage
pkg) ((FilePath -> FilePath -> IO BuildResult) -> IO BuildResult)
-> (FilePath -> FilePath -> IO BuildResult) -> IO BuildResult
forall a b. (a -> b) -> a -> b
$

          case ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg of
            BuildStyle
BuildAndInstall  -> FilePath -> FilePath -> IO BuildResult
buildAndInstall
            BuildStyle
BuildInplaceOnly -> BuildStatusRebuild -> FilePath -> FilePath -> 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 -> FilePath -> IO BuildResult
    rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult
rebuildPhase BuildStatusRebuild
buildStatus FilePath
srcdir =
        Bool -> IO BuildResult -> IO BuildResult
forall a. HasCallStack => Bool -> a -> a
assert (ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
pkg BuildStyle -> BuildStyle -> Bool
forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly) (IO BuildResult -> IO BuildResult)
-> IO BuildResult -> IO BuildResult
forall a b. (a -> b) -> a -> b
$

          BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
buildInplace BuildStatusRebuild
buildStatus FilePath
srcdir FilePath
builddir
      where
        builddir :: FilePath
builddir = DistDirParams -> FilePath
distBuildDirectory
                   (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
sharedPackageConfig ElaboratedConfiguredPackage
pkg)

    buildAndInstall :: FilePath -> FilePath -> IO BuildResult
    buildAndInstall :: FilePath -> FilePath -> IO BuildResult
buildAndInstall FilePath
srcdir FilePath
builddir =
        Verbosity
-> DistDirLayout
-> StoreDirLayout
-> BuildTimeSettings
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> FilePath
-> FilePath
-> IO BuildResult
buildAndInstallUnpackedPackage
          Verbosity
verbosity DistDirLayout
distDirLayout StoreDirLayout
storeDirLayout
          BuildTimeSettings
buildSettings Lock
registerLock Lock
cacheLock
          ElaboratedSharedConfig
sharedPackageConfig
          ElaboratedInstallPlan
plan GenericReadyPackage ElaboratedConfiguredPackage
rpkg
          FilePath
srcdir FilePath
builddir'
      where
        builddir' :: FilePath
builddir' = FilePath -> FilePath -> FilePath
makeRelative FilePath
srcdir FilePath
builddir
        --TODO: [nice to have] ^^ do this relative stuff better

    buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
    buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
buildInplace BuildStatusRebuild
buildStatus FilePath
srcdir FilePath
builddir =
        --TODO: [nice to have] use a relative build dir rather than absolute
        Verbosity
-> DistDirLayout
-> BuildTimeSettings
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> BuildStatusRebuild
-> FilePath
-> FilePath
-> IO BuildResult
buildInplaceUnpackedPackage
          Verbosity
verbosity DistDirLayout
distDirLayout
          BuildTimeSettings
buildSettings Lock
registerLock Lock
cacheLock
          ElaboratedSharedConfig
sharedPackageConfig
          ElaboratedInstallPlan
plan GenericReadyPackage ElaboratedConfiguredPackage
rpkg
          BuildStatusRebuild
buildStatus
          FilePath
srcdir FilePath
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 :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return DownloadedSourceLocation
loc
      Maybe DownloadedSourceLocation
Nothing  -> FilePath -> IO DownloadedSourceLocation
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
_ PackageId
_ 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
  -> (FilePath -> -- Source directory
      FilePath -> -- Build directory
      IO a)
  -> IO a
withTarballLocalDirectory :: Verbosity
-> DistDirLayout
-> FilePath
-> PackageId
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
-> (FilePath -> FilePath -> IO a)
-> IO a
withTarballLocalDirectory Verbosity
verbosity distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{FilePath
FilePath -> FilePath
PackageId -> FilePath
CompilerId -> PackageDB
DistDirParams -> FilePath
DistDirParams -> FilePath -> FilePath
distPackageDB :: CompilerId -> PackageDB
distBinDirectory :: FilePath
distTempDirectory :: FilePath
distSdistDirectory :: FilePath
distSdistFile :: PackageId -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distPackageCacheFile :: DistDirParams -> FilePath -> FilePath
distProjectCacheDirectory :: FilePath
distProjectCacheFile :: FilePath -> FilePath
distUnpackedSrcRootDirectory :: FilePath
distUnpackedSrcDirectory :: PackageId -> FilePath
distDownloadSrcDirectory :: FilePath
distBuildRootDirectory :: FilePath
distBuildDirectory :: DistDirParams -> FilePath
distDirectory :: FilePath
distProjectFile :: FilePath -> FilePath
distProjectRootDirectory :: FilePath
distPackageDB :: DistDirLayout -> CompilerId -> PackageDB
distBinDirectory :: DistDirLayout -> FilePath
distTempDirectory :: DistDirLayout -> FilePath
distSdistDirectory :: DistDirLayout -> FilePath
distSdistFile :: DistDirLayout -> PackageId -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distPackageCacheFile :: DistDirLayout -> DistDirParams -> FilePath -> FilePath
distProjectCacheDirectory :: DistDirLayout -> FilePath
distProjectCacheFile :: DistDirLayout -> FilePath -> FilePath
distUnpackedSrcRootDirectory :: DistDirLayout -> FilePath
distUnpackedSrcDirectory :: DistDirLayout -> PackageId -> FilePath
distDownloadSrcDirectory :: DistDirLayout -> FilePath
distBuildRootDirectory :: DistDirLayout -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distDirectory :: DistDirLayout -> FilePath
distProjectFile :: DistDirLayout -> FilePath -> FilePath
distProjectRootDirectory :: DistDirLayout -> FilePath
..}
                          FilePath
tarball PackageId
pkgid DistDirParams
dparams BuildStyle
buildstyle Maybe CabalFileText
pkgTextOverride
                          FilePath -> FilePath -> 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 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
            Verbosity
-> FilePath
-> FilePath
-> PackageId
-> Maybe CabalFileText
-> IO ()
unpackPackageTarball Verbosity
verbosity FilePath
tarball FilePath
unpackdir
                                 PackageId
pkgid Maybe CabalFileText
pkgTextOverride
            let srcdir :: FilePath
srcdir   = FilePath
unpackdir FilePath -> FilePath -> FilePath
</> PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid
                builddir :: FilePath
builddir = FilePath
srcdir FilePath -> FilePath -> FilePath
</> FilePath
"dist"
            FilePath -> FilePath -> IO a
buildPkg FilePath
srcdir FilePath
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
        BuildStyle
BuildInplaceOnly -> do
          let srcrootdir :: FilePath
srcrootdir = FilePath
distUnpackedSrcRootDirectory
              srcdir :: FilePath
srcdir     = PackageId -> FilePath
distUnpackedSrcDirectory PackageId
pkgid
              builddir :: FilePath
builddir   = DistDirParams -> FilePath
distBuildDirectory DistDirParams
dparams
          -- TODO: [nice to have] use a proper file monitor rather
          -- than this dir exists test
          Bool
exists <- FilePath -> IO Bool
doesDirectoryExist FilePath
srcdir
          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
-> PackageId
-> Maybe CabalFileText
-> IO ()
unpackPackageTarball Verbosity
verbosity FilePath
tarball FilePath
srcrootdir
                                 PackageId
pkgid Maybe CabalFileText
pkgTextOverride
            Verbosity
-> DistDirLayout -> FilePath -> PackageId -> DistDirParams -> IO ()
moveTarballShippedDistDirectory Verbosity
verbosity DistDirLayout
distDirLayout
                                            FilePath
srcrootdir PackageId
pkgid DistDirParams
dparams
          FilePath -> FilePath -> IO a
buildPkg FilePath
srcdir FilePath
builddir


unpackPackageTarball :: Verbosity -> FilePath -> FilePath
                     -> PackageId -> Maybe CabalFileText
                     -> IO ()
unpackPackageTarball :: Verbosity
-> FilePath
-> FilePath
-> PackageId
-> Maybe CabalFileText
-> IO ()
unpackPackageTarball Verbosity
verbosity FilePath
tarball FilePath
parentdir PackageId
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 -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"Package .cabal file not found in the tarball: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cabalFile

      -- Overwrite the .cabal with the one from the index, when appropriate
      --
      case Maybe CabalFileText
pkgTextOverride of
        Maybe CabalFileText
Nothing     -> () -> IO ()
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 = PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid
    pkgname :: PackageName
pkgname   = PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
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 -> PackageId -> DistDirParams -> IO ()
moveTarballShippedDistDirectory Verbosity
verbosity DistDirLayout{DistDirParams -> FilePath
distBuildDirectory :: DistDirParams -> FilePath
distBuildDirectory :: DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory}
                                FilePath
parentdir PackageId
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
</> PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid FilePath -> FilePath -> FilePath
</> FilePath
"dist"
    targetDistDir :: FilePath
targetDistDir  = DistDirParams -> FilePath
distBuildDirectory DistDirParams
dparams


buildAndInstallUnpackedPackage :: Verbosity
                               -> DistDirLayout
                               -> StoreDirLayout
                               -> BuildTimeSettings -> Lock -> Lock
                               -> ElaboratedSharedConfig
                               -> ElaboratedInstallPlan
                               -> ElaboratedReadyPackage
                               -> FilePath -> FilePath
                               -> IO BuildResult
buildAndInstallUnpackedPackage :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> BuildTimeSettings
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> FilePath
-> FilePath
-> IO BuildResult
buildAndInstallUnpackedPackage Verbosity
verbosity
                               distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout{FilePath
distTempDirectory :: FilePath
distTempDirectory :: DistDirLayout -> FilePath
distTempDirectory}
                               storeDirLayout :: StoreDirLayout
storeDirLayout@StoreDirLayout {
                                 CompilerId -> [PackageDB]
storePackageDBStack :: StoreDirLayout -> CompilerId -> [PackageDB]
storePackageDBStack :: CompilerId -> [PackageDB]
storePackageDBStack
                               }
                               BuildTimeSettings {
                                 Int
buildSettingNumJobs :: Int
buildSettingNumJobs :: BuildTimeSettings -> Int
buildSettingNumJobs,
                                 Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingLogFile :: BuildTimeSettings
-> Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingLogFile :: Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingLogFile
                               }
                               Lock
registerLock Lock
cacheLock
                               pkgshared :: ElaboratedSharedConfig
pkgshared@ElaboratedSharedConfig {
                                 pkgConfigPlatform :: ElaboratedSharedConfig -> Platform
pkgConfigPlatform      = Platform
platform,
                                 pkgConfigCompiler :: ElaboratedSharedConfig -> Compiler
pkgConfigCompiler      = Compiler
compiler,
                                 pkgConfigCompilerProgs :: ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs = ProgramDb
progdb
                               }
                               ElaboratedInstallPlan
plan rpkg :: GenericReadyPackage ElaboratedConfiguredPackage
rpkg@(ReadyPackage ElaboratedConfiguredPackage
pkg)
                               FilePath
srcdir FilePath
builddir = do

    Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (FilePath
srcdir FilePath -> FilePath -> FilePath
</> FilePath
builddir)
    IO ()
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
    ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressStarting

    Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a.
Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailure Maybe FilePath
mlogFile SomeException -> BuildFailureReason
ConfigureFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      CommandUI ConfigFlags
-> (Version -> ConfigFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup' CommandUI ConfigFlags
configureCommand Version -> ConfigFlags
configureFlags Version -> [FilePath]
configureArgs

    -- Build phase
    ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressBuilding

    Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a.
Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailure Maybe FilePath
mlogFile SomeException -> BuildFailureReason
BuildFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      CommandUI BuildFlags -> (Version -> BuildFlags) -> IO ()
forall flags. CommandUI flags -> (Version -> flags) -> IO ()
setup CommandUI BuildFlags
buildCommand Version -> BuildFlags
buildFlags

    -- Haddock phase
    IO () -> IO ()
whenHaddock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressHaddock
      (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
HaddocksFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        CommandUI HaddockFlags -> (Version -> HaddockFlags) -> IO ()
forall flags. CommandUI flags -> (Version -> flags) -> IO ()
setup CommandUI HaddockFlags
haddockCommand Version -> HaddockFlags
haddockFlags

    -- Install phase
    ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressInstalling
    Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a.
Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailure Maybe FilePath
mlogFile SomeException -> BuildFailureReason
InstallFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do

      let copyPkgFiles :: FilePath -> IO (FilePath, [FilePath])
copyPkgFiles FilePath
tmpDir = do
            let tmpDirNormalised :: FilePath
tmpDirNormalised = FilePath -> FilePath
normalise FilePath
tmpDir
            CommandUI CopyFlags -> (Version -> CopyFlags) -> IO ()
forall flags. CommandUI flags -> (Version -> flags) -> IO ()
setup CommandUI CopyFlags
Cabal.copyCommand (FilePath -> Version -> CopyFlags
copyFlags FilePath
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 :: FilePath
prefix   = FilePath -> FilePath
normalise (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
                           FilePath -> FilePath
dropDrive (InstallDirs FilePath -> FilePath
forall dir. InstallDirs dir -> dir
InstallDirs.prefix (ElaboratedConfiguredPackage -> InstallDirs FilePath
elabInstallDirs ElaboratedConfiguredPackage
pkg))
                entryDir :: FilePath
entryDir = FilePath
tmpDirNormalised FilePath -> FilePath -> FilePath
</> FilePath
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
            Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
entryDir

            let hashFileName :: FilePath
hashFileName     = FilePath
entryDir FilePath -> FilePath -> FilePath
</> FilePath
"cabal-hash.txt"
                outPkgHashInputs :: CabalFileText
outPkgHashInputs = PackageHashInputs -> CabalFileText
renderPackageHashInputs (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> PackageHashInputs
packageHashInputs ElaboratedSharedConfig
pkgshared ElaboratedConfiguredPackage
pkg)

            Verbosity -> FilePath -> IO ()
info Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
              FilePath
"creating file with the inputs used to compute the package hash: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
hashFileName

            FilePath -> CabalFileText -> IO ()
LBS.writeFile FilePath
hashFileName CabalFileText
outPkgHashInputs

            Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity FilePath
"Package hash inputs:"
            (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
              (Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> (FilePath -> FilePath) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"> " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++))
              (FilePath -> [FilePath]
lines (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ CabalFileText -> FilePath
LBS.Char8.unpack CabalFileText
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.
            [FilePath]
otherFiles <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
entryDir) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                          FilePath -> IO [FilePath]
listFilesRecursive FilePath
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.
            (FilePath, [FilePath]) -> IO (FilePath, [FilePath])
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
entryDir, [FilePath]
otherFiles)
            where
              listFilesRecursive :: FilePath -> IO [FilePath]
              listFilesRecursive :: FilePath -> IO [FilePath]
listFilesRecursive FilePath
path = do
                [FilePath]
files <- (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath
path FilePath -> FilePath -> FilePath
</>) ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO [FilePath]
listDirectory FilePath
path)
                [[FilePath]]
allFiles <- [FilePath] -> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [FilePath]
files ((FilePath -> IO [FilePath]) -> IO [[FilePath]])
-> (FilePath -> IO [FilePath]) -> IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
                  Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
file
                  if Bool
isDir
                    then FilePath -> IO [FilePath]
listFilesRecursive FilePath
file
                    else [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath
file]
                [FilePath] -> IO [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
allFiles)

          registerPkg :: IO ()
registerPkg
            | Bool -> Bool
not (ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration ElaboratedConfiguredPackage
pkg) =
              Verbosity -> FilePath -> IO ()
debug Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
                FilePath
"registerPkg: elab does NOT require registration for "
                FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnitId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnitId
uid
            | Bool
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.
            InstalledPackageInfo
ipkg0 <- IO InstalledPackageInfo
generateInstalledPackageInfo
            let ipkg :: InstalledPackageInfo
ipkg = InstalledPackageInfo
ipkg0 { installedUnitId :: UnitId
Installed.installedUnitId = UnitId
uid }
            Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (   ElaboratedConfiguredPackage -> [PackageDB]
elabRegisterPackageDBStack ElaboratedConfiguredPackage
pkg
                    [PackageDB] -> [PackageDB] -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerId -> [PackageDB]
storePackageDBStack CompilerId
compid) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
criticalSection Lock
registerLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Verbosity
-> Compiler
-> ProgramDb
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
Cabal.registerPackage
                Verbosity
verbosity Compiler
compiler ProgramDb
progdb
                (CompilerId -> [PackageDB]
storePackageDBStack CompilerId
compid) InstalledPackageInfo
ipkg
                RegisterOptions
Cabal.defaultRegisterOptions {
                  registerMultiInstance :: Bool
Cabal.registerMultiInstance      = Bool
True,
                  registerSuppressFilesCheck :: Bool
Cabal.registerSuppressFilesCheck = Bool
True
                }


      -- Actual installation
      IO NewStoreEntryOutcome -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO NewStoreEntryOutcome -> IO ())
-> IO NewStoreEntryOutcome -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity
-> StoreDirLayout
-> CompilerId
-> UnitId
-> (FilePath -> IO (FilePath, [FilePath]))
-> IO ()
-> IO NewStoreEntryOutcome
newStoreEntry Verbosity
verbosity StoreDirLayout
storeDirLayout
                           CompilerId
compid UnitId
uid
                           FilePath -> IO (FilePath, [FilePath])
copyPkgFiles IO ()
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 :: DocsResult
docsResult  = DocsResult
DocsNotTried
        testsResult :: TestsResult
testsResult = TestsResult
TestsNotTried

    ProgressPhase -> IO ()
noticeProgress ProgressPhase
ProgressCompleted

    BuildResult -> IO BuildResult
forall (m :: * -> *) a. Monad m => a -> m a
return BuildResult :: DocsResult -> TestsResult -> Maybe FilePath -> BuildResult
BuildResult {
       buildResultDocs :: DocsResult
buildResultDocs    = DocsResult
docsResult,
       buildResultTests :: TestsResult
buildResultTests   = TestsResult
testsResult,
       buildResultLogFile :: Maybe FilePath
buildResultLogFile = Maybe FilePath
mlogFile
    }

  where
    pkgid :: PackageId
pkgid  = GenericReadyPackage ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericReadyPackage ElaboratedConfiguredPackage
rpkg
    uid :: UnitId
uid    = GenericReadyPackage ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericReadyPackage ElaboratedConfiguredPackage
rpkg
    compid :: CompilerId
compid = Compiler -> CompilerId
compilerId Compiler
compiler

    dispname :: String
    dispname :: FilePath
dispname = case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
pkg of
        ElabPackage ElaboratedPackage
_ -> PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (all, legacy fallback)"
        ElabComponent ElaboratedComponent
comp -> PackageId -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageId
pkgid
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
-> (ComponentName -> FilePath) -> Maybe ComponentName -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath
"custom" ComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (ElaboratedComponent -> Maybe ComponentName
compComponentName ElaboratedComponent
comp) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"

    noticeProgress :: ProgressPhase -> IO ()
    noticeProgress :: ProgressPhase -> IO ()
noticeProgress ProgressPhase
phase = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isParallelBuild (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> ProgressPhase -> FilePath -> IO ()
progressMessage Verbosity
verbosity ProgressPhase
phase FilePath
dispname

    isParallelBuild :: Bool
isParallelBuild = Int
buildSettingNumJobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2

    whenHaddock :: IO () -> IO ()
whenHaddock IO ()
action
      | ElaboratedConfiguredPackage -> Bool
hasValidHaddockTargets ElaboratedConfiguredPackage
pkg = IO ()
action
      | Bool
otherwise                  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    configureCommand :: CommandUI ConfigFlags
configureCommand = ProgramDb -> CommandUI ConfigFlags
Cabal.configureCommand ProgramDb
defaultProgramDb
    configureFlags :: Version -> ConfigFlags
configureFlags Version
v = (ConfigFlags -> Version -> ConfigFlags)
-> Version -> ConfigFlags -> ConfigFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConfigFlags -> Version -> ConfigFlags
filterConfigureFlags Version
v (ConfigFlags -> ConfigFlags) -> ConfigFlags -> ConfigFlags
forall a b. (a -> b) -> a -> b
$
                       GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> ConfigFlags
setupHsConfigureFlags GenericReadyPackage ElaboratedConfiguredPackage
rpkg ElaboratedSharedConfig
pkgshared
                                             Verbosity
verbosity FilePath
builddir
    configureArgs :: Version -> [FilePath]
configureArgs Version
_  = ElaboratedConfiguredPackage -> [FilePath]
setupHsConfigureArgs ElaboratedConfiguredPackage
pkg

    buildCommand :: CommandUI BuildFlags
buildCommand     = ProgramDb -> CommandUI BuildFlags
Cabal.buildCommand ProgramDb
defaultProgramDb
    buildFlags :: Version -> BuildFlags
buildFlags   Version
_   = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> BuildFlags
setupHsBuildFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared Verbosity
verbosity FilePath
builddir

    haddockCommand :: CommandUI HaddockFlags
haddockCommand   = CommandUI HaddockFlags
Cabal.haddockCommand
    haddockFlags :: Version -> HaddockFlags
haddockFlags Version
_   = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> HaddockFlags
setupHsHaddockFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                           Verbosity
verbosity FilePath
builddir

    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo :: IO InstalledPackageInfo
generateInstalledPackageInfo =
      Verbosity
-> FilePath -> (FilePath -> IO ()) -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile
        Verbosity
verbosity FilePath
distTempDirectory ((FilePath -> IO ()) -> IO InstalledPackageInfo)
-> (FilePath -> IO ()) -> IO InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ \FilePath
pkgConfDest -> do
        let registerFlags :: Version -> RegisterFlags
registerFlags Version
_ = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> FilePath
-> RegisterFlags
setupHsRegisterFlags
                                ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                Verbosity
verbosity FilePath
builddir
                                FilePath
pkgConfDest
        CommandUI RegisterFlags -> (Version -> RegisterFlags) -> IO ()
forall flags. CommandUI flags -> (Version -> flags) -> IO ()
setup CommandUI RegisterFlags
Cabal.registerCommand Version -> RegisterFlags
registerFlags

    copyFlags :: FilePath -> Version -> CopyFlags
copyFlags FilePath
destdir Version
_ = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> FilePath
-> CopyFlags
setupHsCopyFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared Verbosity
verbosity
                                           FilePath
builddir FilePath
destdir

    scriptOptions :: SetupScriptOptions
scriptOptions = GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> DistDirLayout
-> FilePath
-> FilePath
-> Bool
-> Lock
-> SetupScriptOptions
setupHsScriptOptions GenericReadyPackage ElaboratedConfiguredPackage
rpkg ElaboratedInstallPlan
plan ElaboratedSharedConfig
pkgshared
                                         DistDirLayout
distDirLayout FilePath
srcdir FilePath
builddir
                                         Bool
isParallelBuild Lock
cacheLock

    setup :: CommandUI flags -> (Version -> flags) -> IO ()
    setup :: CommandUI flags -> (Version -> flags) -> IO ()
setup CommandUI flags
cmd Version -> flags
flags = CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup' CommandUI flags
cmd Version -> flags
flags ([FilePath] -> Version -> [FilePath]
forall a b. a -> b -> a
const [])

    setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
           -> IO ()
    setup' :: CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup' CommandUI flags
cmd Version -> flags
flags Version -> [FilePath]
args =
      (Maybe Handle -> IO ()) -> IO ()
forall r. (Maybe Handle -> IO r) -> IO r
withLogging ((Maybe Handle -> IO ()) -> IO ())
-> (Maybe Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Maybe Handle
mLogFileHandle ->
        Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
setupWrapper
          Verbosity
verbosity
          SetupScriptOptions
scriptOptions
            { useLoggingHandle :: Maybe Handle
useLoggingHandle     = Maybe Handle
mLogFileHandle
            , useExtraEnvOverrides :: [(FilePath, Maybe FilePath)]
useExtraEnvOverrides = DistDirLayout
-> ElaboratedInstallPlan -> [(FilePath, Maybe FilePath)]
dataDirsEnvironmentForPlan
                                     DistDirLayout
distDirLayout ElaboratedInstallPlan
plan }
          (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg))
          CommandUI flags
cmd Version -> flags
flags Version -> [FilePath]
args

    mlogFile :: Maybe FilePath
    mlogFile :: Maybe FilePath
mlogFile =
      case Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
buildSettingLogFile of
        Maybe (Compiler -> Platform -> PackageId -> UnitId -> FilePath)
Nothing        -> Maybe FilePath
forall a. Maybe a
Nothing
        Just Compiler -> Platform -> PackageId -> UnitId -> FilePath
mkLogFile -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Compiler -> Platform -> PackageId -> UnitId -> FilePath
mkLogFile Compiler
compiler Platform
platform PackageId
pkgid UnitId
uid)

    initLogFile :: IO ()
    initLogFile :: IO ()
initLogFile =
      case Maybe FilePath
mlogFile of
        Maybe FilePath
Nothing      -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just FilePath
logFile -> do
          Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
logFile)
          Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
logFile
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeFile FilePath
logFile

    withLogging :: (Maybe Handle -> IO r) -> IO r
    withLogging :: (Maybe Handle -> IO r) -> IO r
withLogging Maybe Handle -> IO r
action =
      case Maybe FilePath
mlogFile of
        Maybe FilePath
Nothing      -> Maybe Handle -> IO r
action Maybe Handle
forall a. Maybe a
Nothing
        Just FilePath
logFile -> FilePath -> IOMode -> (Handle -> IO r) -> IO r
forall r. FilePath -> IOMode -> (Handle -> IO r) -> IO r
withFile FilePath
logFile IOMode
AppendMode (Maybe Handle -> IO r
action (Maybe Handle -> IO r)
-> (Handle -> Maybe Handle) -> Handle -> IO r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Maybe Handle
forall a. a -> Maybe a
Just)


hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
hasValidHaddockTargets ElaboratedConfiguredPackage{Bool
[FilePath]
[Maybe PackageDB]
[PackageDB]
[PathTemplate]
[ComponentTarget]
Maybe FilePath
Maybe TestShowDetails
Maybe PathTemplate
Maybe CabalFileText
Maybe PackageSourceHash
Maybe ComponentTarget
PackageDescription
PackageId
UnitId
ComponentId
Map FilePath FilePath
Map FilePath [FilePath]
Map ModuleName Module
Map ModuleName OpenModule
HaddockTarget
OptimisationLevel
DebugInfoLevel
ProfDetailLevel
DumpBuildInfo
InstallDirs FilePath
ModuleShape
Version
ComponentRequestedSpec
FlagAssignment
OptionalStanzaSet
OptionalStanzaMap (Maybe Bool)
UnresolvedPkgLoc
SetupScriptStyle
BuildStyle
ElaboratedPackageOrComponent
elabConfigureTargets :: ElaboratedConfiguredPackage -> [ComponentTarget]
elabSetupScriptCliVersion :: ElaboratedConfiguredPackage -> Version
elabSetupScriptStyle :: ElaboratedConfiguredPackage -> SetupScriptStyle
elabTestFailWhenNoTestSuites :: ElaboratedConfiguredPackage -> Bool
elabTestWrapper :: ElaboratedConfiguredPackage -> Maybe FilePath
elabHaddockContents :: ElaboratedConfiguredPackage -> Maybe PathTemplate
elabHaddockHscolourCss :: ElaboratedConfiguredPackage -> Maybe FilePath
elabHaddockQuickJump :: ElaboratedConfiguredPackage -> Bool
elabHaddockLinkedSource :: ElaboratedConfiguredPackage -> Bool
elabHaddockCss :: ElaboratedConfiguredPackage -> Maybe FilePath
elabHaddockInternal :: ElaboratedConfiguredPackage -> Bool
elabHaddockBenchmarks :: ElaboratedConfiguredPackage -> Bool
elabHaddockTestSuites :: ElaboratedConfiguredPackage -> Bool
elabHaddockExecutables :: ElaboratedConfiguredPackage -> Bool
elabHaddockForHackage :: ElaboratedConfiguredPackage -> HaddockTarget
elabHaddockForeignLibs :: ElaboratedConfiguredPackage -> Bool
elabHaddockHtmlLocation :: ElaboratedConfiguredPackage -> Maybe FilePath
elabHaddockHtml :: ElaboratedConfiguredPackage -> Bool
elabHaddockHoogle :: ElaboratedConfiguredPackage -> Bool
elabProgSuffix :: ElaboratedConfiguredPackage -> Maybe PathTemplate
elabProgPrefix :: ElaboratedConfiguredPackage -> Maybe PathTemplate
elabExtraIncludeDirs :: ElaboratedConfiguredPackage -> [FilePath]
elabExtraFrameworkDirs :: ElaboratedConfiguredPackage -> [FilePath]
elabExtraLibDirsStatic :: ElaboratedConfiguredPackage -> [FilePath]
elabExtraLibDirs :: ElaboratedConfiguredPackage -> [FilePath]
elabConfigureScriptArgs :: ElaboratedConfiguredPackage -> [FilePath]
elabProgramPathExtra :: ElaboratedConfiguredPackage -> [FilePath]
elabProgramArgs :: ElaboratedConfiguredPackage -> Map FilePath [FilePath]
elabProgramPaths :: ElaboratedConfiguredPackage -> Map FilePath FilePath
elabDumpBuildInfo :: ElaboratedConfiguredPackage -> DumpBuildInfo
elabDebugInfo :: ElaboratedConfiguredPackage -> DebugInfoLevel
elabStripExes :: ElaboratedConfiguredPackage -> Bool
elabStripLibs :: ElaboratedConfiguredPackage -> Bool
elabSplitSections :: ElaboratedConfiguredPackage -> Bool
elabSplitObjs :: ElaboratedConfiguredPackage -> Bool
elabOptimization :: ElaboratedConfiguredPackage -> OptimisationLevel
elabCoverage :: ElaboratedConfiguredPackage -> Bool
elabProfExeDetail :: ElaboratedConfiguredPackage -> ProfDetailLevel
elabProfLibDetail :: ElaboratedConfiguredPackage -> ProfDetailLevel
elabProfExe :: ElaboratedConfiguredPackage -> Bool
elabProfLib :: ElaboratedConfiguredPackage -> Bool
elabGHCiLib :: ElaboratedConfiguredPackage -> Bool
elabFullyStaticExe :: ElaboratedConfiguredPackage -> Bool
elabDynExe :: ElaboratedConfiguredPackage -> Bool
elabStaticLib :: ElaboratedConfiguredPackage -> Bool
elabSharedLib :: ElaboratedConfiguredPackage -> Bool
elabVanillaLib :: ElaboratedConfiguredPackage -> Bool
elabInplaceRegisterPackageDBStack :: ElaboratedConfiguredPackage -> [PackageDB]
elabInplaceBuildPackageDBStack :: ElaboratedConfiguredPackage -> [PackageDB]
elabInplaceSetupPackageDBStack :: ElaboratedConfiguredPackage -> [PackageDB]
elabPackageDbs :: ElaboratedConfiguredPackage -> [Maybe PackageDB]
elabStanzasRequested :: ElaboratedConfiguredPackage -> OptionalStanzaMap (Maybe Bool)
elabStanzasAvailable :: ElaboratedConfiguredPackage -> OptionalStanzaSet
elabEnabledSpec :: ElaboratedConfiguredPackage -> ComponentRequestedSpec
elabLocalToProject :: ElaboratedConfiguredPackage -> Bool
elabPkgSourceHash :: ElaboratedConfiguredPackage -> Maybe PackageSourceHash
elabFlagDefaults :: ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment :: ElaboratedConfiguredPackage -> FlagAssignment
elabModuleShape :: ElaboratedConfiguredPackage -> ModuleShape
elabPkgSourceId :: ElaboratedConfiguredPackage -> PackageId
elabIsCanonical :: ElaboratedConfiguredPackage -> Bool
elabLinkedInstantiatedWith :: ElaboratedConfiguredPackage -> Map ModuleName OpenModule
elabInstantiatedWith :: ElaboratedConfiguredPackage -> Map ModuleName Module
elabComponentId :: ElaboratedConfiguredPackage -> ComponentId
elabUnitId :: ElaboratedConfiguredPackage -> UnitId
elabPkgOrComp :: ElaboratedPackageOrComponent
elabBuildHaddocks :: Bool
elabHaddockTargets :: [ComponentTarget]
elabReplTarget :: Maybe ComponentTarget
elabBenchTargets :: [ComponentTarget]
elabTestTargets :: [ComponentTarget]
elabBuildTargets :: [ComponentTarget]
elabConfigureTargets :: [ComponentTarget]
elabSetupScriptCliVersion :: Version
elabSetupScriptStyle :: SetupScriptStyle
elabBenchmarkOptions :: [PathTemplate]
elabTestTestOptions :: [PathTemplate]
elabTestFailWhenNoTestSuites :: Bool
elabTestWrapper :: Maybe FilePath
elabTestKeepTix :: Bool
elabTestShowDetails :: Maybe TestShowDetails
elabTestHumanLog :: Maybe PathTemplate
elabTestMachineLog :: Maybe PathTemplate
elabHaddockContents :: Maybe PathTemplate
elabHaddockHscolourCss :: Maybe FilePath
elabHaddockQuickJump :: Bool
elabHaddockLinkedSource :: Bool
elabHaddockCss :: Maybe FilePath
elabHaddockInternal :: Bool
elabHaddockBenchmarks :: Bool
elabHaddockTestSuites :: Bool
elabHaddockExecutables :: Bool
elabHaddockForHackage :: HaddockTarget
elabHaddockForeignLibs :: Bool
elabHaddockHtmlLocation :: Maybe FilePath
elabHaddockHtml :: Bool
elabHaddockHoogle :: Bool
elabInstallDirs :: InstallDirs FilePath
elabProgSuffix :: Maybe PathTemplate
elabProgPrefix :: Maybe PathTemplate
elabExtraIncludeDirs :: [FilePath]
elabExtraFrameworkDirs :: [FilePath]
elabExtraLibDirsStatic :: [FilePath]
elabExtraLibDirs :: [FilePath]
elabConfigureScriptArgs :: [FilePath]
elabProgramPathExtra :: [FilePath]
elabProgramArgs :: Map FilePath [FilePath]
elabProgramPaths :: Map FilePath FilePath
elabDumpBuildInfo :: DumpBuildInfo
elabDebugInfo :: DebugInfoLevel
elabStripExes :: Bool
elabStripLibs :: Bool
elabSplitSections :: Bool
elabSplitObjs :: Bool
elabOptimization :: OptimisationLevel
elabCoverage :: Bool
elabProfExeDetail :: ProfDetailLevel
elabProfLibDetail :: ProfDetailLevel
elabProfExe :: Bool
elabProfLib :: Bool
elabGHCiLib :: Bool
elabFullyStaticExe :: Bool
elabDynExe :: Bool
elabStaticLib :: Bool
elabSharedLib :: Bool
elabVanillaLib :: Bool
elabPkgDescriptionOverride :: Maybe CabalFileText
elabInplaceRegisterPackageDBStack :: [PackageDB]
elabInplaceBuildPackageDBStack :: [PackageDB]
elabInplaceSetupPackageDBStack :: [PackageDB]
elabRegisterPackageDBStack :: [PackageDB]
elabBuildPackageDBStack :: [PackageDB]
elabSetupPackageDBStack :: [PackageDB]
elabPackageDbs :: [Maybe PackageDB]
elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)
elabStanzasAvailable :: OptionalStanzaSet
elabEnabledSpec :: ComponentRequestedSpec
elabBuildStyle :: BuildStyle
elabLocalToProject :: Bool
elabPkgSourceHash :: Maybe PackageSourceHash
elabPkgSourceLocation :: UnresolvedPkgLoc
elabPkgDescription :: PackageDescription
elabFlagDefaults :: FlagAssignment
elabFlagAssignment :: FlagAssignment
elabModuleShape :: ModuleShape
elabPkgSourceId :: PackageId
elabIsCanonical :: Bool
elabLinkedInstantiatedWith :: Map ModuleName OpenModule
elabInstantiatedWith :: Map ModuleName Module
elabComponentId :: ComponentId
elabUnitId :: UnitId
elabPkgDescription :: ElaboratedConfiguredPackage -> PackageDescription
elabPkgOrComp :: ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabInstallDirs :: ElaboratedConfiguredPackage -> InstallDirs FilePath
elabPkgDescriptionOverride :: ElaboratedConfiguredPackage -> Maybe CabalFileText
elabSetupPackageDBStack :: ElaboratedConfiguredPackage -> [PackageDB]
elabRegisterPackageDBStack :: ElaboratedConfiguredPackage -> [PackageDB]
elabBuildPackageDBStack :: ElaboratedConfiguredPackage -> [PackageDB]
elabBenchmarkOptions :: ElaboratedConfiguredPackage -> [PathTemplate]
elabTestTestOptions :: ElaboratedConfiguredPackage -> [PathTemplate]
elabTestKeepTix :: ElaboratedConfiguredPackage -> Bool
elabTestShowDetails :: ElaboratedConfiguredPackage -> Maybe TestShowDetails
elabTestHumanLog :: ElaboratedConfiguredPackage -> Maybe PathTemplate
elabTestMachineLog :: ElaboratedConfiguredPackage -> Maybe PathTemplate
elabBuildHaddocks :: ElaboratedConfiguredPackage -> Bool
elabHaddockTargets :: ElaboratedConfiguredPackage -> [ComponentTarget]
elabReplTarget :: ElaboratedConfiguredPackage -> Maybe ComponentTarget
elabBenchTargets :: ElaboratedConfiguredPackage -> [ComponentTarget]
elabTestTargets :: ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets :: ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildStyle :: ElaboratedConfiguredPackage -> BuildStyle
elabPkgSourceLocation :: ElaboratedConfiguredPackage -> UnresolvedPkgLoc
..}
  | Bool -> Bool
not Bool
elabBuildHaddocks = Bool
False
  | Bool
otherwise             = (ComponentTarget -> Bool) -> [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ComponentTarget -> Bool
componentHasHaddocks [ComponentTarget]
components
  where
    components :: [ComponentTarget]
    components :: [ComponentTarget]
components = [ComponentTarget]
elabBuildTargets [ComponentTarget] -> [ComponentTarget] -> [ComponentTarget]
forall a. [a] -> [a] -> [a]
++ [ComponentTarget]
elabTestTargets [ComponentTarget] -> [ComponentTarget] -> [ComponentTarget]
forall a. [a] -> [a] -> [a]
++ [ComponentTarget]
elabBenchTargets
              [ComponentTarget] -> [ComponentTarget] -> [ComponentTarget]
forall a. [a] -> [a] -> [a]
++ Maybe ComponentTarget -> [ComponentTarget]
forall a. Maybe a -> [a]
maybeToList Maybe ComponentTarget
elabReplTarget [ComponentTarget] -> [ComponentTarget] -> [ComponentTarget]
forall a. [a] -> [a] -> [a]
++ [ComponentTarget]
elabHaddockTargets

    componentHasHaddocks :: ComponentTarget -> Bool
    componentHasHaddocks :: ComponentTarget -> Bool
componentHasHaddocks (ComponentTarget ComponentName
name SubComponentTarget
_) =
      case ComponentName
name of
        CLibName LibraryName
LMainLibName    ->                           Bool
hasHaddocks
        CLibName (LSubLibName UnqualComponentName
_) -> Bool
elabHaddockInternal    Bool -> Bool -> Bool
&& Bool
hasHaddocks
        CFLibName              UnqualComponentName
_ -> Bool
elabHaddockForeignLibs Bool -> Bool -> Bool
&& Bool
hasHaddocks
        CExeName               UnqualComponentName
_ -> Bool
elabHaddockExecutables Bool -> Bool -> Bool
&& Bool
hasHaddocks
        CTestName              UnqualComponentName
_ -> Bool
elabHaddockTestSuites  Bool -> Bool -> Bool
&& Bool
hasHaddocks
        CBenchName             UnqualComponentName
_ -> Bool
elabHaddockBenchmarks  Bool -> Bool -> Bool
&& Bool
hasHaddocks
      where
        hasHaddocks :: Bool
hasHaddocks = Bool -> Bool
not ([ModuleName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageDescription
elabPkgDescription PackageDescription
-> Getting [ModuleName] PackageDescription [ModuleName]
-> [ModuleName]
forall s a. s -> Getting a s a -> a
^. ComponentName
-> Getting [ModuleName] PackageDescription [ModuleName]
forall r.
Monoid r =>
ComponentName -> Getting r PackageDescription [ModuleName]
componentModules ComponentName
name))


buildInplaceUnpackedPackage :: Verbosity
                            -> DistDirLayout
                            -> BuildTimeSettings -> Lock -> Lock
                            -> ElaboratedSharedConfig
                            -> ElaboratedInstallPlan
                            -> ElaboratedReadyPackage
                            -> BuildStatusRebuild
                            -> FilePath -> FilePath
                            -> IO BuildResult
buildInplaceUnpackedPackage :: Verbosity
-> DistDirLayout
-> BuildTimeSettings
-> Lock
-> Lock
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> BuildStatusRebuild
-> FilePath
-> FilePath
-> IO BuildResult
buildInplaceUnpackedPackage Verbosity
verbosity
                            distDirLayout :: DistDirLayout
distDirLayout@DistDirLayout {
                              FilePath
distTempDirectory :: FilePath
distTempDirectory :: DistDirLayout -> FilePath
distTempDirectory,
                              DistDirParams -> FilePath
distPackageCacheDirectory :: DistDirParams -> FilePath
distPackageCacheDirectory :: DistDirLayout -> DistDirParams -> FilePath
distPackageCacheDirectory,
                              FilePath
distDirectory :: FilePath
distDirectory :: DistDirLayout -> FilePath
distDirectory
                            }
                            BuildTimeSettings{Int
buildSettingNumJobs :: Int
buildSettingNumJobs :: BuildTimeSettings -> Int
buildSettingNumJobs, Bool
buildSettingHaddockOpen :: BuildTimeSettings -> Bool
buildSettingHaddockOpen :: Bool
buildSettingHaddockOpen}
                            Lock
registerLock Lock
cacheLock
                            pkgshared :: ElaboratedSharedConfig
pkgshared@ElaboratedSharedConfig {
                              pkgConfigCompiler :: ElaboratedSharedConfig -> Compiler
pkgConfigCompiler      = Compiler
compiler,
                              pkgConfigCompilerProgs :: ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs = ProgramDb
progdb,
                              pkgConfigPlatform :: ElaboratedSharedConfig -> Platform
pkgConfigPlatform      = Platform
platform
                            }
                            ElaboratedInstallPlan
plan
                            rpkg :: GenericReadyPackage ElaboratedConfiguredPackage
rpkg@(ReadyPackage ElaboratedConfiguredPackage
pkg)
                            BuildStatusRebuild
buildStatus
                            FilePath
srcdir FilePath
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
        Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
builddir
        Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True
          (DistDirParams -> FilePath
distPackageCacheDirectory DistDirParams
dparams)

        -- Configure phase
        --
        IO () -> IO ()
whenReConfigure (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
ConfigureFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            CommandUI ConfigFlags
-> (Version -> ConfigFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI ConfigFlags
configureCommand Version -> ConfigFlags
configureFlags Version -> [FilePath]
configureArgs
          PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor PackageFileMonitor
packageFileMonitor
          PackageFileMonitor
-> FilePath -> ElaboratedConfiguredPackage -> IO ()
updatePackageConfigFileMonitor PackageFileMonitor
packageFileMonitor FilePath
srcdir ElaboratedConfiguredPackage
pkg

        -- Build phase
        --
        let docsResult :: DocsResult
docsResult  = DocsResult
DocsNotTried
            testsResult :: TestsResult
testsResult = TestsResult
TestsNotTried

            buildResult :: BuildResultMisc
            buildResult :: BuildResultMisc
buildResult = (DocsResult
docsResult, TestsResult
testsResult)

        IO () -> IO ()
whenRebuild (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          MonitorTimestamp
timestamp <- IO MonitorTimestamp
beginUpdateFileMonitor
          (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
BuildFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            CommandUI BuildFlags
-> (Version -> BuildFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI BuildFlags
buildCommand Version -> BuildFlags
buildFlags Version -> [FilePath]
buildArgs

          let listSimple :: IO [MonitorFilePath]
listSimple =
                FilePath -> Rebuild () -> IO [MonitorFilePath]
forall a. FilePath -> Rebuild a -> IO [MonitorFilePath]
execRebuild FilePath
srcdir (ElaboratedConfiguredPackage -> Rebuild ()
needElaboratedConfiguredPackage ElaboratedConfiguredPackage
pkg)
              listSdist :: IO [MonitorFilePath]
listSdist =
                ([FilePath] -> [MonitorFilePath])
-> IO [FilePath] -> IO [MonitorFilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FilePath -> MonitorFilePath) -> [FilePath] -> [MonitorFilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> MonitorFilePath
monitorFileHashed) (IO [FilePath] -> IO [MonitorFilePath])
-> IO [FilePath] -> IO [MonitorFilePath]
forall a b. (a -> b) -> a -> b
$
                    Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles Verbosity
verbosity FilePath
srcdir
              ifNullThen :: m (t a) -> m (t a) -> m (t a)
ifNullThen m (t a)
m m (t a)
m' = do t a
xs <- m (t a)
m
                                   if t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t a
xs then m (t a)
m' else t a -> m (t a)
forall (m :: * -> *) a. Monad m => a -> m a
return t a
xs
          [MonitorFilePath]
monitors <- case PackageDescription -> BuildType
PD.buildType (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg) of
            BuildType
Simple -> IO [MonitorFilePath]
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.
            BuildType
_ | ElaboratedConfiguredPackage -> Version
elabSetupScriptCliVersion ElaboratedConfiguredPackage
pkg Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
1,Int
17]
              -- However, sometimes sdist --list-sources will fail
              -- and return an empty list.  In that case, fall
              -- back on the (inaccurate) simple tracking.
              -> IO [MonitorFilePath]
listSdist IO [MonitorFilePath]
-> IO [MonitorFilePath] -> IO [MonitorFilePath]
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t) =>
m (t a) -> m (t a) -> m (t a)
`ifNullThen` IO [MonitorFilePath]
listSimple
              | Bool
otherwise
              -> IO [MonitorFilePath]
listSimple

          let dep_monitors :: [MonitorFilePath]
dep_monitors = (FilePath -> MonitorFilePath) -> [FilePath] -> [MonitorFilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> MonitorFilePath
monitorFileHashed
                           ([FilePath] -> [MonitorFilePath])
-> [FilePath] -> [MonitorFilePath]
forall a b. (a -> b) -> a -> b
$ DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> ElaboratedConfiguredPackage
-> [FilePath]
elabInplaceDependencyBuildCacheFiles
                                DistDirLayout
distDirLayout ElaboratedSharedConfig
pkgshared ElaboratedInstallPlan
plan ElaboratedConfiguredPackage
pkg
          PackageFileMonitor
-> FilePath
-> MonitorTimestamp
-> ElaboratedConfiguredPackage
-> BuildStatusRebuild
-> [MonitorFilePath]
-> BuildResultMisc
-> IO ()
updatePackageBuildFileMonitor PackageFileMonitor
packageFileMonitor FilePath
srcdir MonitorTimestamp
timestamp
                                        ElaboratedConfiguredPackage
pkg BuildStatusRebuild
buildStatus
                                        ([MonitorFilePath]
monitors [MonitorFilePath] -> [MonitorFilePath] -> [MonitorFilePath]
forall a. [a] -> [a] -> [a]
++ [MonitorFilePath]
dep_monitors) BuildResultMisc
buildResult

        -- PURPOSELY omitted: no copy!

        IO () -> IO ()
whenReRegister (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
InstallFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- Register locally
          Maybe InstalledPackageInfo
mipkg <- if ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration ElaboratedConfiguredPackage
pkg
            then do
                InstalledPackageInfo
ipkg0 <- IO InstalledPackageInfo
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 :: InstalledPackageInfo
ipkg = InstalledPackageInfo
ipkg0 { installedUnitId :: UnitId
Installed.installedUnitId = UnitId
ipkgid }
                Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
criticalSection Lock
registerLock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    Verbosity
-> Compiler
-> ProgramDb
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
Cabal.registerPackage Verbosity
verbosity Compiler
compiler ProgramDb
progdb
                                          (ElaboratedConfiguredPackage -> [PackageDB]
elabRegisterPackageDBStack ElaboratedConfiguredPackage
pkg)
                                          InstalledPackageInfo
ipkg RegisterOptions
Cabal.defaultRegisterOptions
                Maybe InstalledPackageInfo -> IO (Maybe InstalledPackageInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageInfo -> Maybe InstalledPackageInfo
forall a. a -> Maybe a
Just InstalledPackageInfo
ipkg)

           else Maybe InstalledPackageInfo -> IO (Maybe InstalledPackageInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe InstalledPackageInfo
forall a. Maybe a
Nothing

          PackageFileMonitor
-> FilePath -> Maybe InstalledPackageInfo -> IO ()
updatePackageRegFileMonitor PackageFileMonitor
packageFileMonitor FilePath
srcdir Maybe InstalledPackageInfo
mipkg

        IO () -> IO ()
whenTest (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
TestsFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            CommandUI TestFlags
-> (Version -> TestFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI TestFlags
testCommand Version -> TestFlags
testFlags Version -> [FilePath]
testArgs

        IO () -> IO ()
whenBench (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
BenchFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            CommandUI BenchmarkFlags
-> (Version -> BenchmarkFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI BenchmarkFlags
benchCommand Version -> BenchmarkFlags
benchFlags Version -> [FilePath]
benchArgs

        -- Repl phase
        --
        IO () -> IO ()
whenRepl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
ReplFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          CommandUI ReplFlags
-> (Version -> ReplFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setupInteractive CommandUI ReplFlags
replCommand Version -> ReplFlags
replFlags Version -> [FilePath]
replArgs

        -- Haddock phase
        IO () -> IO ()
whenHaddock (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          (SomeException -> BuildFailureReason) -> IO () -> IO ()
forall a. (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
HaddocksFailed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            CommandUI HaddockFlags
-> (Version -> HaddockFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI HaddockFlags
haddockCommand Version -> HaddockFlags
haddockFlags Version -> [FilePath]
haddockArgs
            let haddockTarget :: HaddockTarget
haddockTarget = ElaboratedConfiguredPackage -> HaddockTarget
elabHaddockForHackage ElaboratedConfiguredPackage
pkg
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HaddockTarget
haddockTarget HaddockTarget -> HaddockTarget -> Bool
forall a. Eq a => a -> a -> Bool
== HaddockTarget
Cabal.ForHackage) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              let dest :: FilePath
dest = FilePath
distDirectory FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
<.> FilePath
"tar.gz"
                  name :: FilePath
name = HaddockTarget -> PackageDescription -> FilePath
haddockDirName HaddockTarget
haddockTarget (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg)
                  docDir :: FilePath
docDir = DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory DistDirLayout
distDirLayout DistDirParams
dparams
                           FilePath -> FilePath -> FilePath
</> FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath
"html"
              FilePath -> FilePath -> FilePath -> IO ()
Tar.createTarGzFile FilePath
dest FilePath
docDir FilePath
name
              Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Documentation tarball created: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
dest

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
buildSettingHaddockOpen Bool -> Bool -> Bool
&& HaddockTarget
haddockTarget HaddockTarget -> HaddockTarget -> Bool
forall a. Eq a => a -> a -> Bool
/= HaddockTarget
Cabal.ForHackage) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              let dest :: FilePath
dest = FilePath
docDir FilePath -> FilePath -> FilePath
</> FilePath
name FilePath -> FilePath -> FilePath
</> FilePath
"index.html"
                  name :: FilePath
name = HaddockTarget -> PackageDescription -> FilePath
haddockDirName HaddockTarget
haddockTarget (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg)
                  docDir :: FilePath
docDir = DistDirLayout -> DistDirParams -> FilePath
distBuildDirectory DistDirLayout
distDirLayout DistDirParams
dparams
                           FilePath -> FilePath -> FilePath
</> FilePath
"doc" FilePath -> FilePath -> FilePath
</> FilePath
"html"
              Either FilePath FilePath
exe <- Platform -> IO (Either FilePath FilePath)
findOpenProgramLocation Platform
platform
              case Either FilePath FilePath
exe of
                Right FilePath
open -> Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (FilePath -> [FilePath] -> ProgramInvocation
simpleProgramInvocation FilePath
open [FilePath
dest])
                Left FilePath
err -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
err


        BuildResult -> IO BuildResult
forall (m :: * -> *) a. Monad m => a -> m a
return BuildResult :: DocsResult -> TestsResult -> Maybe FilePath -> BuildResult
BuildResult {
          buildResultDocs :: DocsResult
buildResultDocs    = DocsResult
docsResult,
          buildResultTests :: TestsResult
buildResultTests   = TestsResult
testsResult,
          buildResultLogFile :: Maybe FilePath
buildResultLogFile = Maybe FilePath
forall a. Maybe a
Nothing
        }

  where
    ipkgid :: UnitId
ipkgid  = ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg
    dparams :: DistDirParams
dparams = ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
pkgshared ElaboratedConfiguredPackage
pkg

    isParallelBuild :: Bool
isParallelBuild = Int
buildSettingNumJobs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2

    packageFileMonitor :: PackageFileMonitor
packageFileMonitor = ElaboratedSharedConfig
-> DistDirLayout -> DistDirParams -> PackageFileMonitor
newPackageFileMonitor ElaboratedSharedConfig
pkgshared DistDirLayout
distDirLayout DistDirParams
dparams

    whenReConfigure :: IO () -> IO ()
whenReConfigure IO ()
action = case BuildStatusRebuild
buildStatus of
      BuildStatusConfigure MonitorChangedReason ()
_ -> IO ()
action
      BuildStatusRebuild
_                      -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    whenRebuild :: IO () -> IO ()
whenRebuild IO ()
action
      | [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets ElaboratedConfiguredPackage
pkg)
      -- NB: we have to build the test/bench suite!
      , [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabTestTargets ElaboratedConfiguredPackage
pkg)
      , [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabBenchTargets ElaboratedConfiguredPackage
pkg) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise                   = IO ()
action

    whenTest :: IO () -> IO ()
whenTest IO ()
action
      | [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabTestTargets ElaboratedConfiguredPackage
pkg) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise                  = IO ()
action

    whenBench :: IO () -> IO ()
whenBench IO ()
action
      | [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabBenchTargets ElaboratedConfiguredPackage
pkg) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise                   = IO ()
action

    whenRepl :: IO () -> IO ()
whenRepl IO ()
action
      | Maybe ComponentTarget -> Bool
forall a. Maybe a -> Bool
isNothing (ElaboratedConfiguredPackage -> Maybe ComponentTarget
elabReplTarget ElaboratedConfiguredPackage
pkg) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise                     = IO ()
action

    whenHaddock :: IO () -> IO ()
whenHaddock IO ()
action
      | ElaboratedConfiguredPackage -> Bool
hasValidHaddockTargets ElaboratedConfiguredPackage
pkg = IO ()
action
      | Bool
otherwise                  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    whenReRegister :: IO () -> IO ()
whenReRegister  IO ()
action
      = case BuildStatusRebuild
buildStatus of
          -- We registered the package already
          BuildStatusBuild (Just Maybe InstalledPackageInfo
_) BuildReason
_     ->
            Verbosity -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"whenReRegister: previously registered"
          -- There is nothing to register
          BuildStatusRebuild
_ | [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets ElaboratedConfiguredPackage
pkg) ->
              Verbosity -> FilePath -> IO ()
info Verbosity
verbosity FilePath
"whenReRegister: nothing to register"
            | Bool
otherwise                   -> IO ()
action

    configureCommand :: CommandUI ConfigFlags
configureCommand = ProgramDb -> CommandUI ConfigFlags
Cabal.configureCommand ProgramDb
defaultProgramDb
    configureFlags :: Version -> ConfigFlags
configureFlags Version
v = (ConfigFlags -> Version -> ConfigFlags)
-> Version -> ConfigFlags -> ConfigFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip ConfigFlags -> Version -> ConfigFlags
filterConfigureFlags Version
v (ConfigFlags -> ConfigFlags) -> ConfigFlags -> ConfigFlags
forall a b. (a -> b) -> a -> b
$
                       GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> ConfigFlags
setupHsConfigureFlags GenericReadyPackage ElaboratedConfiguredPackage
rpkg ElaboratedSharedConfig
pkgshared
                                             Verbosity
verbosity FilePath
builddir
    configureArgs :: Version -> [FilePath]
configureArgs Version
_  = ElaboratedConfiguredPackage -> [FilePath]
setupHsConfigureArgs ElaboratedConfiguredPackage
pkg

    buildCommand :: CommandUI BuildFlags
buildCommand     = ProgramDb -> CommandUI BuildFlags
Cabal.buildCommand ProgramDb
defaultProgramDb
    buildFlags :: Version -> BuildFlags
buildFlags   Version
_   = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> BuildFlags
setupHsBuildFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                         Verbosity
verbosity FilePath
builddir
    buildArgs :: Version -> [FilePath]
buildArgs     Version
_  = ElaboratedConfiguredPackage -> [FilePath]
setupHsBuildArgs  ElaboratedConfiguredPackage
pkg

    testCommand :: CommandUI TestFlags
testCommand      = CommandUI TestFlags
Cabal.testCommand -- defaultProgramDb
    testFlags :: Version -> TestFlags
testFlags      Version
v = (TestFlags -> Version -> TestFlags)
-> Version -> TestFlags -> TestFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip TestFlags -> Version -> TestFlags
filterTestFlags Version
v (TestFlags -> TestFlags) -> TestFlags -> TestFlags
forall a b. (a -> b) -> a -> b
$
                       ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> TestFlags
setupHsTestFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                         Verbosity
verbosity FilePath
builddir
    testArgs :: Version -> [FilePath]
testArgs      Version
_  = ElaboratedConfiguredPackage -> [FilePath]
setupHsTestArgs  ElaboratedConfiguredPackage
pkg

    benchCommand :: CommandUI BenchmarkFlags
benchCommand     = CommandUI BenchmarkFlags
Cabal.benchmarkCommand
    benchFlags :: Version -> BenchmarkFlags
benchFlags    Version
_  = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> BenchmarkFlags
setupHsBenchFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                          Verbosity
verbosity FilePath
builddir
    benchArgs :: Version -> [FilePath]
benchArgs     Version
_  = ElaboratedConfiguredPackage -> [FilePath]
setupHsBenchArgs  ElaboratedConfiguredPackage
pkg

    replCommand :: CommandUI ReplFlags
replCommand      = ProgramDb -> CommandUI ReplFlags
Cabal.replCommand ProgramDb
defaultProgramDb
    replFlags :: Version -> ReplFlags
replFlags Version
_      = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> ReplFlags
setupHsReplFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                        Verbosity
verbosity FilePath
builddir
    replArgs :: Version -> [FilePath]
replArgs Version
_       = ElaboratedConfiguredPackage -> [FilePath]
setupHsReplArgs  ElaboratedConfiguredPackage
pkg

    haddockCommand :: CommandUI HaddockFlags
haddockCommand   = CommandUI HaddockFlags
Cabal.haddockCommand
    haddockFlags :: Version -> HaddockFlags
haddockFlags Version
v   = (HaddockFlags -> Version -> HaddockFlags)
-> Version -> HaddockFlags -> HaddockFlags
forall a b c. (a -> b -> c) -> b -> a -> c
flip HaddockFlags -> Version -> HaddockFlags
filterHaddockFlags Version
v (HaddockFlags -> HaddockFlags) -> HaddockFlags -> HaddockFlags
forall a b. (a -> b) -> a -> b
$
                       ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> FilePath -> HaddockFlags
setupHsHaddockFlags ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                           Verbosity
verbosity FilePath
builddir
    haddockArgs :: Version -> [FilePath]
haddockArgs    Version
v = ([FilePath] -> Version -> [FilePath])
-> Version -> [FilePath] -> [FilePath]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [FilePath] -> Version -> [FilePath]
filterHaddockArgs Version
v ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
                       ElaboratedConfiguredPackage -> [FilePath]
setupHsHaddockArgs ElaboratedConfiguredPackage
pkg

    scriptOptions :: SetupScriptOptions
scriptOptions    = GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> DistDirLayout
-> FilePath
-> FilePath
-> Bool
-> Lock
-> SetupScriptOptions
setupHsScriptOptions GenericReadyPackage ElaboratedConfiguredPackage
rpkg ElaboratedInstallPlan
plan ElaboratedSharedConfig
pkgshared
                                            DistDirLayout
distDirLayout FilePath
srcdir FilePath
builddir
                                            Bool
isParallelBuild Lock
cacheLock

    setupInteractive :: CommandUI flags
                     -> (Version -> flags) -> (Version -> [String]) -> IO ()
    setupInteractive :: CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setupInteractive CommandUI flags
cmd Version -> flags
flags Version -> [FilePath]
args =
      Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
setupWrapper Verbosity
verbosity
                   SetupScriptOptions
scriptOptions { isInteractive :: Bool
isInteractive = Bool
True }
                   (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg))
                   CommandUI flags
cmd Version -> flags
flags Version -> [FilePath]
args

    setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
          -> IO ()
    setup :: CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI flags
cmd Version -> flags
flags Version -> [FilePath]
args =
      Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
forall flags.
Verbosity
-> SetupScriptOptions
-> Maybe PackageDescription
-> CommandUI flags
-> (Version -> flags)
-> (Version -> [FilePath])
-> IO ()
setupWrapper Verbosity
verbosity
                   SetupScriptOptions
scriptOptions
                   (PackageDescription -> Maybe PackageDescription
forall a. a -> Maybe a
Just (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg))
                   CommandUI flags
cmd Version -> flags
flags Version -> [FilePath]
args

    generateInstalledPackageInfo :: IO InstalledPackageInfo
    generateInstalledPackageInfo :: IO InstalledPackageInfo
generateInstalledPackageInfo =
      Verbosity
-> FilePath -> (FilePath -> IO ()) -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile
        Verbosity
verbosity FilePath
distTempDirectory ((FilePath -> IO ()) -> IO InstalledPackageInfo)
-> (FilePath -> IO ()) -> IO InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ \FilePath
pkgConfDest -> do
        let registerFlags :: Version -> RegisterFlags
registerFlags Version
_ = ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> FilePath
-> RegisterFlags
setupHsRegisterFlags
                                ElaboratedConfiguredPackage
pkg ElaboratedSharedConfig
pkgshared
                                Verbosity
verbosity FilePath
builddir
                                FilePath
pkgConfDest
        CommandUI RegisterFlags
-> (Version -> RegisterFlags) -> (Version -> [FilePath]) -> IO ()
forall flags.
CommandUI flags
-> (Version -> flags) -> (Version -> [FilePath]) -> IO ()
setup CommandUI RegisterFlags
Cabal.registerCommand Version -> RegisterFlags
registerFlags ([FilePath] -> Version -> [FilePath]
forall a b. a -> b -> a
const [])

withTempInstalledPackageInfoFile :: Verbosity -> FilePath
                                  -> (FilePath -> IO ())
                                  -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile :: Verbosity
-> FilePath -> (FilePath -> IO ()) -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile Verbosity
verbosity FilePath
tempdir FilePath -> IO ()
action =
    Verbosity
-> FilePath
-> FilePath
-> (FilePath -> IO InstalledPackageInfo)
-> IO InstalledPackageInfo
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
tempdir FilePath
"package-registration-" ((FilePath -> IO InstalledPackageInfo) -> IO InstalledPackageInfo)
-> (FilePath -> IO InstalledPackageInfo) -> IO InstalledPackageInfo
forall a b. (a -> b) -> a -> b
$ \FilePath
dir -> do
      -- make absolute since @action@ will often change directory
      FilePath
abs_dir <- FilePath -> IO FilePath
canonicalizePath FilePath
dir

      let pkgConfDest :: FilePath
pkgConfDest = FilePath
abs_dir FilePath -> FilePath -> FilePath
</> FilePath
"pkgConf"
      FilePath -> IO ()
action FilePath
pkgConfDest

      FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf FilePath
"." FilePath
pkgConfDest
  where
    pkgConfParseFailed :: String -> IO a
    pkgConfParseFailed :: FilePath -> IO a
pkgConfParseFailed FilePath
perror =
      Verbosity -> FilePath -> IO a
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO a) -> FilePath -> IO a
forall a b. (a -> b) -> a -> b
$
      FilePath
"Couldn't parse the output of 'setup register --gen-pkg-config':"
      FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
perror

    readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
    readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf FilePath
pkgConfDir FilePath
pkgConfFile = do
      ByteString
pkgConfStr <- FilePath -> IO ByteString
BS.readFile (FilePath
pkgConfDir FilePath -> FilePath -> FilePath
</> FilePath
pkgConfFile)
      ([FilePath]
warns, InstalledPackageInfo
ipkg) <- case ByteString
-> Either (NonEmpty FilePath) ([FilePath], InstalledPackageInfo)
Installed.parseInstalledPackageInfo ByteString
pkgConfStr of
        Left NonEmpty FilePath
perrors -> FilePath -> IO ([FilePath], InstalledPackageInfo)
forall a. FilePath -> IO a
pkgConfParseFailed (FilePath -> IO ([FilePath], InstalledPackageInfo))
-> FilePath -> IO ([FilePath], InstalledPackageInfo)
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
perrors
        Right ([FilePath]
warns, InstalledPackageInfo
ipkg) -> ([FilePath], InstalledPackageInfo)
-> IO ([FilePath], InstalledPackageInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath]
warns, InstalledPackageInfo
ipkg)

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
warns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines [FilePath]
warns

      InstalledPackageInfo -> IO InstalledPackageInfo
forall (m :: * -> *) a. Monad m => a -> m a
return InstalledPackageInfo
ipkg


------------------------------------------------------------------------------
-- * Utilities
------------------------------------------------------------------------------

annotateFailureNoLog :: (SomeException -> BuildFailureReason)
                     -> IO a -> IO a
annotateFailureNoLog :: (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailureNoLog SomeException -> BuildFailureReason
annotate IO a
action =
  Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO a -> IO a
forall a.
Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailure Maybe FilePath
forall a. Maybe a
Nothing SomeException -> BuildFailureReason
annotate IO a
action

annotateFailure :: Maybe FilePath
                -> (SomeException -> BuildFailureReason)
                -> IO a -> IO a
annotateFailure :: Maybe FilePath
-> (SomeException -> BuildFailureReason) -> IO a -> IO a
annotateFailure Maybe FilePath
mlogFile SomeException -> BuildFailureReason
annotate IO a
action =
  IO a
action IO a -> [Handler a] -> IO a
forall a. IO a -> [Handler a] -> IO a
`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)
      (SomeAsyncException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeAsyncException -> IO a) -> Handler a)
-> (SomeAsyncException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \SomeAsyncException
async -> SomeAsyncException -> IO a
forall e a. Exception e => e -> IO a
throwIO (SomeAsyncException
async :: SomeAsyncException)
#else
      Handler $ \async -> throwIO (async :: AsyncException)
#endif
    , (SomeException -> IO a) -> Handler a
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO a) -> Handler a)
-> (SomeException -> IO a) -> Handler a
forall a b. (a -> b) -> a -> b
$ \SomeException
other -> SomeException -> IO a
forall e a. Exception e => e -> IO a
handler (SomeException
other :: SomeException)
    ]
  where
    handler :: Exception e => e -> IO a
    handler :: e -> IO a
handler = BuildFailure -> IO a
forall e a. Exception e => e -> IO a
throwIO (BuildFailure -> IO a) -> (e -> BuildFailure) -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> BuildFailureReason -> BuildFailure
BuildFailure Maybe FilePath
mlogFile (BuildFailureReason -> BuildFailure)
-> (e -> BuildFailureReason) -> e -> BuildFailure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> BuildFailureReason
annotate (SomeException -> BuildFailureReason)
-> (e -> SomeException) -> e -> BuildFailureReason
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeException
forall e. Exception e => e -> SomeException
toException