{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

-- | This module deals with building and incrementally rebuilding a collection
-- of packages. It is what backs the @cabal build@ and @configure@ commands,
-- as well as being a core part of @run@, @test@, @bench@ and others.
--
-- The primary thing is in fact rebuilding (and trying to make that quick by
-- not redoing unnecessary work), so building from scratch is just a special
-- case.
--
-- The build process and the code can be understood by breaking it down into
-- three major parts:
--
-- * The 'ElaboratedInstallPlan' type
--
-- * The \"what to do\" phase, where we look at the all input configuration
--   (project files, .cabal files, command line etc) and produce a detailed
--   plan of what to do -- the 'ElaboratedInstallPlan'.
--
-- * The \"do it\" phase, where we take the 'ElaboratedInstallPlan' and we
-- re-execute it.
--
-- As far as possible, the \"what to do\" phase embodies all the policy, leaving
-- the \"do it\" phase policy free. The first phase contains more of the
-- complicated logic, but it is contained in code that is either pure or just
-- has read effects (except cache updates). Then the second phase does all the
-- actions to build packages, but as far as possible it just follows the
-- instructions and avoids any logic for deciding what to do (apart from
-- recompilation avoidance in executing the plan).
--
-- This division helps us keep the code under control, making it easier to
-- understand, test and debug. So when you are extending these modules, please
-- think about which parts of your change belong in which part. It is
-- perfectly ok to extend the description of what to do (i.e. the
-- 'ElaboratedInstallPlan') if that helps keep the policy decisions in the
-- first phase. Also, the second phase does not have direct access to any of
-- the input configuration anyway; all the information has to flow via the
-- 'ElaboratedInstallPlan'.
--
module Distribution.Client.ProjectOrchestration (
    -- * Discovery phase: what is in the project?
    CurrentCommand(..),
    establishProjectBaseContext,
    establishProjectBaseContextWithRoot,
    ProjectBaseContext(..),
    BuildTimeSettings(..),
    commandLineFlagsToProjectConfig,

    -- * Pre-build phase: decide what to do.
    withInstallPlan,
    runProjectPreBuildPhase,
    ProjectBuildContext(..),

    -- ** Selecting what targets we mean
    readTargetSelectors,
    reportTargetSelectorProblems,
    resolveTargets,
    TargetsMap,
    allTargetSelectors,
    uniqueTargetSelectors,
    TargetSelector(..),
    TargetImplicitCwd(..),
    PackageId,
    AvailableTarget(..),
    AvailableTargetStatus(..),
    TargetRequested(..),
    ComponentName(..),
    ComponentKind(..),
    ComponentTarget(..),
    SubComponentTarget(..),
    selectComponentTargetBasic,
    distinctTargetComponents,
    -- ** Utils for selecting targets
    filterTargetsKind,
    filterTargetsKindWith,
    selectBuildableTargets,
    selectBuildableTargetsWith,
    selectBuildableTargets',
    selectBuildableTargetsWith',
    forgetTargetsDetail,

    -- ** Adjusting the plan
    pruneInstallPlanToTargets,
    TargetAction(..),
    pruneInstallPlanToDependencies,
    CannotPruneDependencies(..),
    printPlan,

    -- * Build phase: now do it.
    runProjectBuildPhase,

    -- * Post build actions
    runProjectPostBuildPhase,
    dieOnBuildFailures,

    -- * Dummy projects
    establishDummyProjectBaseContext,
    establishDummyDistDirLayout,
  ) where

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

import           Distribution.Client.ProjectConfig
import           Distribution.Client.ProjectPlanning
                   hiding ( pruneInstallPlanToTargets )
import qualified Distribution.Client.ProjectPlanning as ProjectPlanning
                   ( pruneInstallPlanToTargets )
import           Distribution.Client.ProjectPlanning.Types
import           Distribution.Client.ProjectBuilding
import           Distribution.Client.ProjectPlanOutput

import           Distribution.Client.TargetProblem
                   ( TargetProblem (..) )
import           Distribution.Client.Types
                   ( GenericReadyPackage(..), UnresolvedSourcePackage
                   , PackageSpecifier(..)
                   , SourcePackageDb(..)
                   , WriteGhcEnvironmentFilesPolicy(..)
                   , PackageLocation(..)
                   , DocsResult(..)
                   , TestsResult(..) )
import           Distribution.Solver.Types.PackageIndex
                   ( lookupPackageName )
import qualified Distribution.Client.InstallPlan as InstallPlan
import           Distribution.Client.TargetSelector
                   ( TargetSelector(..), TargetImplicitCwd(..)
                   , ComponentKind(..), componentKind
                   , readTargetSelectors, reportTargetSelectorProblems )
import           Distribution.Client.DistDirLayout

import           Distribution.Client.BuildReports.Anonymous (cabalInstallID)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
         ( storeLocal )

import           Distribution.Client.HttpUtils
import           Distribution.Client.Setup hiding (packageName)
import           Distribution.Compiler
                   ( CompilerFlavor(GHC) )
import           Distribution.Types.ComponentName
                   ( componentNameString )
import           Distribution.Types.InstalledPackageInfo
                   ( InstalledPackageInfo )
import           Distribution.Types.UnqualComponentName
                   ( UnqualComponentName, packageNameToUnqualComponentName )

import           Distribution.Solver.Types.OptionalStanza

import           Distribution.Package
import           Distribution.Types.Flag
                   ( FlagAssignment, showFlagAssignment, diffFlagAssignment )
import           Distribution.Simple.LocalBuildInfo
                   ( ComponentName(..), pkgComponents )
import           Distribution.Simple.Flag
                   ( fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.Setup as Setup
import           Distribution.Simple.Command (commandShowOptions)
import           Distribution.Simple.Configure (computeEffectiveProfiling)
import           Distribution.Simple.PackageIndex (InstalledPackageIndex)
import           Distribution.Simple.Utils
                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose, ordNub )
import           Distribution.Verbosity
import           Distribution.Version
                   ( mkVersion )
import           Distribution.Simple.Compiler
                   ( compilerCompatVersion, showCompilerId, compilerId, compilerInfo
                   , OptimisationLevel(..))
import           Distribution.Utils.NubList
                   ( fromNubList )
import           Distribution.System
                   ( Platform(Platform) )

import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
import qualified Data.Map as Map
import           Control.Exception ( assert )
#ifdef MIN_VERSION_unix
import           System.Posix.Signals (sigKILL, sigSEGV)
#endif


-- | Tracks what command is being executed, because we need to hide this somewhere
-- for cases that need special handling (usually for error reporting).
data CurrentCommand = InstallCommand | HaddockCommand | BuildCommand | ReplCommand | OtherCommand
                    deriving (Int -> CurrentCommand -> ShowS
[CurrentCommand] -> ShowS
CurrentCommand -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CurrentCommand] -> ShowS
$cshowList :: [CurrentCommand] -> ShowS
show :: CurrentCommand -> String
$cshow :: CurrentCommand -> String
showsPrec :: Int -> CurrentCommand -> ShowS
$cshowsPrec :: Int -> CurrentCommand -> ShowS
Show, CurrentCommand -> CurrentCommand -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CurrentCommand -> CurrentCommand -> Bool
$c/= :: CurrentCommand -> CurrentCommand -> Bool
== :: CurrentCommand -> CurrentCommand -> Bool
$c== :: CurrentCommand -> CurrentCommand -> Bool
Eq)

-- | This holds the context of a project prior to solving: the content of the
-- @cabal.project@ and all the local package @.cabal@ files.
--
data ProjectBaseContext = ProjectBaseContext {
       ProjectBaseContext -> DistDirLayout
distDirLayout  :: DistDirLayout,
       ProjectBaseContext -> CabalDirLayout
cabalDirLayout :: CabalDirLayout,
       ProjectBaseContext -> ProjectConfig
projectConfig  :: ProjectConfig,
       ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages  :: [PackageSpecifier UnresolvedSourcePackage],
       ProjectBaseContext -> BuildTimeSettings
buildSettings  :: BuildTimeSettings,
       ProjectBaseContext -> CurrentCommand
currentCommand :: CurrentCommand,
       ProjectBaseContext -> Maybe InstalledPackageIndex
installedPackages :: Maybe InstalledPackageIndex
     }

establishProjectBaseContext
    :: Verbosity
    -> ProjectConfig
    -> CurrentCommand
    -> IO ProjectBaseContext
establishProjectBaseContext :: Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
currentCommand = do
    ProjectRoot
projectRoot <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
-> Maybe String -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot forall a. Maybe a
Nothing Maybe String
mprojectFile
    Verbosity
-> ProjectConfig
-> ProjectRoot
-> CurrentCommand
-> IO ProjectBaseContext
establishProjectBaseContextWithRoot Verbosity
verbosity ProjectConfig
cliConfig ProjectRoot
projectRoot CurrentCommand
currentCommand
  where
    mprojectFile :: Maybe String
mprojectFile   = forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigProjectFile
    ProjectConfigShared { Flag String
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigProjectFile :: Flag String
projectConfigProjectFile} = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig

-- | Like 'establishProjectBaseContext' but doesn't search for project root.
establishProjectBaseContextWithRoot
    :: Verbosity
    -> ProjectConfig
    -> ProjectRoot
    -> CurrentCommand
    -> IO ProjectBaseContext
establishProjectBaseContextWithRoot :: Verbosity
-> ProjectConfig
-> ProjectRoot
-> CurrentCommand
-> IO ProjectBaseContext
establishProjectBaseContextWithRoot Verbosity
verbosity ProjectConfig
cliConfig ProjectRoot
projectRoot CurrentCommand
currentCommand = do
    let distDirLayout :: DistDirLayout
distDirLayout  = ProjectRoot -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory

    HttpTransport
httpTransport <- Verbosity -> [String] -> Maybe String -> IO HttpTransport
configureTransport Verbosity
verbosity
                     (forall a. NubList a -> [a]
fromNubList forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList String
projectConfigProgPathExtra forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
                     (forall a. Flag a -> Maybe a
flagToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag String
projectConfigHttpTransport forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
cliConfig)

    (ProjectConfig
projectConfig, [PackageSpecifier UnresolvedSourcePackage]
localPackages) <-
      Verbosity
-> HttpTransport
-> DistDirLayout
-> ProjectConfig
-> IO (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage])
rebuildProjectConfig Verbosity
verbosity
                           HttpTransport
httpTransport
                           DistDirLayout
distDirLayout
                           ProjectConfig
cliConfig

    let ProjectConfigBuildOnly {
          Flag String
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigLogsDir :: Flag String
projectConfigLogsDir
        } = ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
projectConfig

        ProjectConfigShared {
          Flag String
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigStoreDir :: Flag String
projectConfigStoreDir
        } = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
projectConfig

        mlogsDir :: Maybe String
mlogsDir = forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigLogsDir
    Maybe String
mstoreDir <- forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute
                 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigStoreDir
    CabalDirLayout
cabalDirLayout <- Maybe String -> Maybe String -> IO CabalDirLayout
mkCabalDirLayout Maybe String
mstoreDir Maybe String
mlogsDir

    let  buildSettings :: BuildTimeSettings
buildSettings = Verbosity -> CabalDirLayout -> ProjectConfig -> BuildTimeSettings
resolveBuildTimeSettings
                          Verbosity
verbosity CabalDirLayout
cabalDirLayout
                          ProjectConfig
projectConfig

    -- https://github.com/haskell/cabal/issues/6013
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ProjectConfig -> [String]
projectPackages ProjectConfig
projectConfig) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ProjectConfig -> [String]
projectPackagesOptional ProjectConfig
projectConfig)) forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"There are no packages or optional-packages in the project"

    forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext {
      DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout,
      CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout,
      ProjectConfig
projectConfig :: ProjectConfig
projectConfig :: ProjectConfig
projectConfig,
      [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages,
      BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings,
      CurrentCommand
currentCommand :: CurrentCommand
currentCommand :: CurrentCommand
currentCommand,
      forall a. Maybe a
installedPackages :: forall a. Maybe a
installedPackages :: Maybe InstalledPackageIndex
installedPackages
    }
  where
    mdistDirectory :: Maybe String
mdistDirectory = forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigDistDir
    ProjectConfigShared { Flag String
projectConfigDistDir :: ProjectConfigShared -> Flag String
projectConfigDistDir :: Flag String
projectConfigDistDir } = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig
    installedPackages :: Maybe a
installedPackages = forall a. Maybe a
Nothing


-- | This holds the context between the pre-build, build and post-build phases.
--
data ProjectBuildContext = ProjectBuildContext {
      -- | This is the improved plan, before we select a plan subset based on
      -- the build targets, and before we do the dry-run. So this contains
      -- all packages in the project.
      ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanOriginal :: ElaboratedInstallPlan,

      -- | This is the 'elaboratedPlanOriginal' after we select a plan subset
      -- and do the dry-run phase to find out what is up-to or out-of date.
      -- This is the plan that will be executed during the build phase. So
      -- this contains only a subset of packages in the project.
      ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute:: ElaboratedInstallPlan,

      -- | The part of the install plan that's shared between all packages in
      -- the plan. This does not change between the two plan variants above,
      -- so there is just the one copy.
      ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared       :: ElaboratedSharedConfig,

      -- | The result of the dry-run phase. This tells us about each member of
      -- the 'elaboratedPlanToExecute'.
      ProjectBuildContext -> BuildStatusMap
pkgsBuildStatus        :: BuildStatusMap,

      -- | The targets selected by @selectPlanSubset@. This is useful eg. in
      -- CmdRun, where we need a valid target to execute.
      ProjectBuildContext -> TargetsMap
targetsMap             :: TargetsMap
    }


-- | Pre-build phase: decide what to do.
--
withInstallPlan
    :: Verbosity
    -> ProjectBaseContext
    -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
    -> IO a
withInstallPlan :: forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan
    Verbosity
verbosity
    ProjectBaseContext {
      DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
distDirLayout,
      CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
cabalDirLayout,
      ProjectConfig
projectConfig :: ProjectConfig
projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig,
      [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages,
      Maybe InstalledPackageIndex
installedPackages :: Maybe InstalledPackageIndex
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
installedPackages
    }
    ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a
action = do
    -- Take the project configuration and make a plan for how to build
    -- everything in the project. This is independent of any specific targets
    -- the user has asked for.
    --
    (ElaboratedInstallPlan
elaboratedPlan, ElaboratedInstallPlan
_, ElaboratedSharedConfig
elaboratedShared, TotalIndexState
_, ActiveRepos
_) <-
      Verbosity
-> DistDirLayout
-> CabalDirLayout
-> ProjectConfig
-> [PackageSpecifier UnresolvedSourcePackage]
-> Maybe InstalledPackageIndex
-> IO
     (ElaboratedInstallPlan, ElaboratedInstallPlan,
      ElaboratedSharedConfig, TotalIndexState, ActiveRepos)
rebuildInstallPlan Verbosity
verbosity
                         DistDirLayout
distDirLayout CabalDirLayout
cabalDirLayout
                         ProjectConfig
projectConfig
                         [PackageSpecifier UnresolvedSourcePackage]
localPackages
                         Maybe InstalledPackageIndex
installedPackages
    ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a
action ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
elaboratedShared

runProjectPreBuildPhase
    :: Verbosity
    -> ProjectBaseContext
    -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
    -> IO ProjectBuildContext
runProjectPreBuildPhase :: Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase
    Verbosity
verbosity
    ProjectBaseContext {
      DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
distDirLayout,
      CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
cabalDirLayout,
      ProjectConfig
projectConfig :: ProjectConfig
projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig,
      [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages,
      Maybe InstalledPackageIndex
installedPackages :: Maybe InstalledPackageIndex
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
installedPackages
    }
    ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)
selectPlanSubset = do
    -- Take the project configuration and make a plan for how to build
    -- everything in the project. This is independent of any specific targets
    -- the user has asked for.
    --
    (ElaboratedInstallPlan
elaboratedPlan, ElaboratedInstallPlan
_, ElaboratedSharedConfig
elaboratedShared, TotalIndexState
_, ActiveRepos
_) <-
      Verbosity
-> DistDirLayout
-> CabalDirLayout
-> ProjectConfig
-> [PackageSpecifier UnresolvedSourcePackage]
-> Maybe InstalledPackageIndex
-> IO
     (ElaboratedInstallPlan, ElaboratedInstallPlan,
      ElaboratedSharedConfig, TotalIndexState, ActiveRepos)
rebuildInstallPlan Verbosity
verbosity
                         DistDirLayout
distDirLayout CabalDirLayout
cabalDirLayout
                         ProjectConfig
projectConfig
                         [PackageSpecifier UnresolvedSourcePackage]
localPackages
                         Maybe InstalledPackageIndex
installedPackages

    -- The plan for what to do is represented by an 'ElaboratedInstallPlan'

    -- Now given the specific targets the user has asked for, decide
    -- which bits of the plan we will want to execute.
    --
    (ElaboratedInstallPlan
elaboratedPlan', TargetsMap
targets) <- ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap)
selectPlanSubset ElaboratedInstallPlan
elaboratedPlan

    -- Check which packages need rebuilding.
    -- This also gives us more accurate reasons for the --dry-run output.
    --
    BuildStatusMap
pkgsBuildStatus <- DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> IO BuildStatusMap
rebuildTargetsDryRun DistDirLayout
distDirLayout ElaboratedSharedConfig
elaboratedShared
                                            ElaboratedInstallPlan
elaboratedPlan'

    -- Improve the plan by marking up-to-date packages as installed.
    --
    let elaboratedPlan'' :: ElaboratedInstallPlan
elaboratedPlan'' = BuildStatusMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages
                             BuildStatusMap
pkgsBuildStatus ElaboratedInstallPlan
elaboratedPlan'
    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> String
InstallPlan.showInstallPlan ElaboratedInstallPlan
elaboratedPlan'')

    forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBuildContext {
      elaboratedPlanOriginal :: ElaboratedInstallPlan
elaboratedPlanOriginal = ElaboratedInstallPlan
elaboratedPlan,
      elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedPlanToExecute = ElaboratedInstallPlan
elaboratedPlan'',
      ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared,
      BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus,
      targetsMap :: TargetsMap
targetsMap = TargetsMap
targets
    }


-- | Build phase: now do it.
--
-- Execute all or parts of the description of what to do to build or
-- rebuild the various packages needed.
--
runProjectBuildPhase :: Verbosity
                     -> ProjectBaseContext
                     -> ProjectBuildContext
                     -> IO BuildOutcomes
runProjectBuildPhase :: Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
_ ProjectBaseContext{BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings :: ProjectBaseContext -> BuildTimeSettings
buildSettings} ProjectBuildContext
_
  | BuildTimeSettings -> Bool
buildSettingDryRun BuildTimeSettings
buildSettings
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall k a. Map k a
Map.empty

runProjectBuildPhase Verbosity
verbosity
                     ProjectBaseContext{[PackageSpecifier UnresolvedSourcePackage]
Maybe InstalledPackageIndex
BuildTimeSettings
ProjectConfig
CabalDirLayout
DistDirLayout
CurrentCommand
installedPackages :: Maybe InstalledPackageIndex
currentCommand :: CurrentCommand
buildSettings :: BuildTimeSettings
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectConfig
cabalDirLayout :: CabalDirLayout
distDirLayout :: DistDirLayout
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
currentCommand :: ProjectBaseContext -> CurrentCommand
buildSettings :: ProjectBaseContext -> BuildTimeSettings
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectBaseContext -> ProjectConfig
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
..} ProjectBuildContext {TargetsMap
BuildStatusMap
ElaboratedInstallPlan
ElaboratedSharedConfig
targetsMap :: TargetsMap
pkgsBuildStatus :: BuildStatusMap
elaboratedShared :: ElaboratedSharedConfig
elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedPlanOriginal :: ElaboratedInstallPlan
targetsMap :: ProjectBuildContext -> TargetsMap
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanOriginal :: ProjectBuildContext -> ElaboratedInstallPlan
..} =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (BuildStatusMap -> BuildOutcomes
previousBuildOutcomes BuildStatusMap
pkgsBuildStatus)) forall a b. (a -> b) -> a -> b
$
    Verbosity
-> DistDirLayout
-> StoreDirLayout
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
-> BuildTimeSettings
-> IO BuildOutcomes
rebuildTargets Verbosity
verbosity
                   DistDirLayout
distDirLayout
                   (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalDirLayout)
                   ElaboratedInstallPlan
elaboratedPlanToExecute
                   ElaboratedSharedConfig
elaboratedShared
                   BuildStatusMap
pkgsBuildStatus
                   BuildTimeSettings
buildSettings
  where
    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
previousBuildOutcomes =
      forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe forall a b. (a -> b) -> a -> b
$ \BuildStatus
status -> case BuildStatus
status of
        BuildStatusUpToDate BuildResult
buildSuccess -> forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right BuildResult
buildSuccess)
        --TODO: [nice to have] record build failures persistently
        BuildStatus
_                                  -> forall a. Maybe a
Nothing

-- | Post-build phase: various administrative tasks
--
-- Update bits of state based on the build outcomes and report any failures.
--
runProjectPostBuildPhase :: Verbosity
                         -> ProjectBaseContext
                         -> ProjectBuildContext
                         -> BuildOutcomes
                         -> IO ()
runProjectPostBuildPhase :: Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
_ ProjectBaseContext{BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings :: ProjectBaseContext -> BuildTimeSettings
buildSettings} ProjectBuildContext
_ BuildOutcomes
_
  | BuildTimeSettings -> Bool
buildSettingDryRun BuildTimeSettings
buildSettings
  = forall (m :: * -> *) a. Monad m => a -> m a
return ()

runProjectPostBuildPhase Verbosity
verbosity
                         ProjectBaseContext {[PackageSpecifier UnresolvedSourcePackage]
Maybe InstalledPackageIndex
BuildTimeSettings
ProjectConfig
CabalDirLayout
DistDirLayout
CurrentCommand
installedPackages :: Maybe InstalledPackageIndex
currentCommand :: CurrentCommand
buildSettings :: BuildTimeSettings
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectConfig
cabalDirLayout :: CabalDirLayout
distDirLayout :: DistDirLayout
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
currentCommand :: ProjectBaseContext -> CurrentCommand
buildSettings :: ProjectBaseContext -> BuildTimeSettings
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectBaseContext -> ProjectConfig
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
..} bc :: ProjectBuildContext
bc@ProjectBuildContext {TargetsMap
BuildStatusMap
ElaboratedInstallPlan
ElaboratedSharedConfig
targetsMap :: TargetsMap
pkgsBuildStatus :: BuildStatusMap
elaboratedShared :: ElaboratedSharedConfig
elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedPlanOriginal :: ElaboratedInstallPlan
targetsMap :: ProjectBuildContext -> TargetsMap
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanOriginal :: ProjectBuildContext -> ElaboratedInstallPlan
..}
                         BuildOutcomes
buildOutcomes = do
    -- Update other build artefacts
    -- TODO: currently none, but could include:
    --        - bin symlinks/wrappers
    --        - haddock/hoogle/ctags indexes
    --        - delete stale lib registrations
    --        - delete stale package dirs

    PostBuildProjectStatus
postBuildStatus <- Verbosity
-> DistDirLayout
-> ElaboratedInstallPlan
-> BuildStatusMap
-> BuildOutcomes
-> IO PostBuildProjectStatus
updatePostBuildProjectStatus
                         Verbosity
verbosity
                         DistDirLayout
distDirLayout
                         ElaboratedInstallPlan
elaboratedPlanOriginal
                         BuildStatusMap
pkgsBuildStatus
                         BuildOutcomes
buildOutcomes

    -- Write the .ghc.environment file (if allowed by the env file write policy).
    let writeGhcEnvFilesPolicy :: Flag WriteGhcEnvironmentFilesPolicy
writeGhcEnvFilesPolicy =
          ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy
projectConfigWriteGhcEnvironmentFilesPolicy forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfig -> ProjectConfigShared
projectConfigShared
          forall a b. (a -> b) -> a -> b
$ ProjectConfig
projectConfig

        shouldWriteGhcEnvironment :: Bool
        shouldWriteGhcEnvironment :: Bool
shouldWriteGhcEnvironment =
          case forall a. a -> Flag a -> a
fromFlagOrDefault WriteGhcEnvironmentFilesPolicy
NeverWriteGhcEnvironmentFiles
               Flag WriteGhcEnvironmentFilesPolicy
writeGhcEnvFilesPolicy
          of
            WriteGhcEnvironmentFilesPolicy
AlwaysWriteGhcEnvironmentFiles                -> Bool
True
            WriteGhcEnvironmentFilesPolicy
NeverWriteGhcEnvironmentFiles                 -> Bool
False
            WriteGhcEnvironmentFilesPolicy
WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->
              let compiler :: Compiler
compiler         = ElaboratedSharedConfig -> Compiler
pkgConfigCompiler ElaboratedSharedConfig
elaboratedShared
                  ghcCompatVersion :: Maybe Version
ghcCompatVersion = CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion CompilerFlavor
GHC Compiler
compiler
              in forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8,Int
4,Int
4]) Maybe Version
ghcCompatVersion

    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldWriteGhcEnvironment forall a b. (a -> b) -> a -> b
$
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ String
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> PostBuildProjectStatus
-> IO (Maybe String)
writePlanGhcEnvironment (DistDirLayout -> String
distProjectRootDirectory DistDirLayout
distDirLayout)
                                     ElaboratedInstallPlan
elaboratedPlanOriginal
                                     ElaboratedSharedConfig
elaboratedShared
                                     PostBuildProjectStatus
postBuildStatus

    -- Write the build reports
    BuildTimeSettings
-> ProjectBuildContext
-> ElaboratedInstallPlan
-> BuildOutcomes
-> IO ()
writeBuildReports BuildTimeSettings
buildSettings ProjectBuildContext
bc ElaboratedInstallPlan
elaboratedPlanToExecute BuildOutcomes
buildOutcomes

    -- Finally if there were any build failures then report them and throw
    -- an exception to terminate the program
    Verbosity
-> CurrentCommand
-> ElaboratedInstallPlan
-> BuildOutcomes
-> IO ()
dieOnBuildFailures Verbosity
verbosity CurrentCommand
currentCommand ElaboratedInstallPlan
elaboratedPlanToExecute BuildOutcomes
buildOutcomes

    -- Note that it is a deliberate design choice that the 'buildTargets' is
    -- not passed to phase 1, and the various bits of input config is not
    -- passed to phase 2.
    --
    -- We make the install plan without looking at the particular targets the
    -- user asks us to build. The set of available things we can build is
    -- discovered from the env and config and is used to make the install plan.
    -- The targets just tell us which parts of the install plan to execute.
    --
    -- Conversely, executing the plan does not directly depend on any of the
    -- input config. The bits that are needed (or better, the decisions based
    -- on it) all go into the install plan.

    -- Notionally, the 'BuildFlags' should be things that do not affect what
    -- we build, just how we do it. These ones of course do


------------------------------------------------------------------------------
-- Taking targets into account, selecting what to build
--

-- | The set of components to build, represented as a mapping from 'UnitId's
-- to the 'ComponentTarget's within the unit that will be selected
-- (e.g. selected to build, test or repl).
--
-- Associated with each 'ComponentTarget' is the set of 'TargetSelector's that
-- matched this target. Typically this is exactly one, but in general it is
-- possible to for different selectors to match the same target. This extra
-- information is primarily to help make helpful error messages.
--
type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]

-- | Get all target selectors.
allTargetSelectors :: TargetsMap -> [TargetSelector]
allTargetSelectors :: TargetsMap -> [TargetSelector]
allTargetSelectors = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. NonEmpty a -> [a]
NE.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems

-- | Get all unique target selectors.
uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
uniqueTargetSelectors = forall a. Ord a => [a] -> [a]
ordNub forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetsMap -> [TargetSelector]
allTargetSelectors

-- | Given a set of 'TargetSelector's, resolve which 'UnitId's and
-- 'ComponentTarget's they ought to refer to.
--
-- The idea is that every user target identifies one or more roots in the
-- 'ElaboratedInstallPlan', which we will use to determine the closure
-- of what packages need to be built, dropping everything from the plan
-- that is unnecessary. This closure and pruning is done by
-- 'pruneInstallPlanToTargets' and this needs to be told the roots in terms
-- of 'UnitId's and the 'ComponentTarget's within those.
--
-- This means we first need to translate the 'TargetSelector's into the
-- 'UnitId's and 'ComponentTarget's. This translation has to be different for
-- the different command line commands, like @build@, @repl@ etc. For example
-- the command @build pkgfoo@ could select a different set of components in
-- pkgfoo than @repl pkgfoo@. The @build@ command would select any library and
-- all executables, whereas @repl@ would select the library or a single
-- executable. Furthermore, both of these examples could fail, and fail in
-- different ways and each needs to be able to produce helpful error messages.
--
-- So 'resolveTargets' takes two helpers: one to select the targets to be used
-- by user targets that refer to a whole package ('TargetPackage'), and
-- another to check user targets that refer to a component (or a module or
-- file within a component). These helpers can fail, and use their own error
-- type. Both helpers get given the 'AvailableTarget' info about the
-- component(s).
--
-- While commands vary quite a bit in their behaviour about which components to
-- select for a whole-package target, most commands have the same behaviour for
-- checking a user target that refers to a specific component. To help with
-- this commands can use 'selectComponentTargetBasic', either directly or as
-- a basis for their own @selectComponentTarget@ implementation.
--
resolveTargets :: forall err.
                  (forall k. TargetSelector
                          -> [AvailableTarget k]
                          -> Either (TargetProblem err) [k])
               -> (forall k. SubComponentTarget
                          -> AvailableTarget k
                          -> Either (TargetProblem err)  k )
               -> ElaboratedInstallPlan
               -> Maybe (SourcePackageDb)
               -> [TargetSelector]
               -> Either [TargetProblem err] TargetsMap
resolveTargets :: forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget
               ElaboratedInstallPlan
installPlan Maybe SourcePackageDb
mPkgDb =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(TargetSelector, [(UnitId, ComponentTarget)])] -> TargetsMap
mkTargetsMap
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) forall a b. b -> Either a b
Right
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. [Either e a] -> Either (NonEmpty e) [a]
checkErrors
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\TargetSelector
ts -> (,) TargetSelector
ts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TargetSelector
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
checkTarget TargetSelector
ts)
  where
    mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])]
                 -> TargetsMap
    mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])] -> TargetsMap
mkTargetsMap [(TargetSelector, [(UnitId, ComponentTarget)])]
targets =
        forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)]
nubComponentTargets
      forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>)
          [ (UnitId
uid, [(ComponentTarget
ct, TargetSelector
ts)])
          | (TargetSelector
ts, [(UnitId, ComponentTarget)]
cts) <- [(TargetSelector, [(UnitId, ComponentTarget)])]
targets
          , (UnitId
uid, ComponentTarget
ct) <- [(UnitId, ComponentTarget)]
cts ]

    AvailableTargetIndexes{AvailableTargetsMap (PackageIdentifier, ComponentName)
AvailableTargetsMap (PackageName, ComponentName)
AvailableTargetsMap (PackageName, UnqualComponentName)
AvailableTargetsMap PackageIdentifier
AvailableTargetsMap PackageName
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetIndexes
-> AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetIndexes
-> AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetIndexes -> AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetIndexes -> AvailableTargetsMap PackageIdentifier
availableTargetsByPackageIdAndComponentName :: AvailableTargetIndexes
-> AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName)
..} = ElaboratedInstallPlan -> AvailableTargetIndexes
availableTargetIndexes ElaboratedInstallPlan
installPlan

    checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]

    -- We can ask to build any whole package, project-local or a dependency
    checkTarget :: TargetSelector
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
checkTarget bt :: TargetSelector
bt@(TargetPackage TargetImplicitCwd
_ [PackageIdentifier
pkgid] Maybe ComponentKindFilter
mkfilter)
      | Just [AvailableTarget (UnitId, ComponentName)]
ats <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter)
                  forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pkgid AvailableTargetsMap PackageIdentifier
availableTargetsByPackageId
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
      forall a b. (a -> b) -> a -> b
$ forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt [AvailableTarget (UnitId, ComponentName)]
ats

      | Bool
otherwise
      = forall a b. a -> Either a b
Left (forall a. PackageIdentifier -> TargetProblem a
TargetProblemNoSuchPackage PackageIdentifier
pkgid)

    checkTarget (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
pkgids Maybe ComponentKindFilter
_)
      = forall a. (?callStack::CallStack) => String -> a
error (String
"TODO: add support for multiple packages in a directory.  Got\n"
              forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
pkgids))
      -- For the moment this error cannot happen here, because it gets
      -- detected when the package config is being constructed. This case
      -- will need handling properly when we do add support.
      --
      -- TODO: how should this use case play together with the
      -- '--cabal-file' option of 'configure' which allows using multiple
      -- .cabal files for a single package?

    checkTarget bt :: TargetSelector
bt@(TargetAllPackages Maybe ComponentKindFilter
mkfilter) =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall k. AvailableTarget k -> Bool
availableTargetLocalToProject
      forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall k a. Map k a -> [a]
Map.elems AvailableTargetsMap PackageIdentifier
availableTargetsByPackageId)

    checkTarget (TargetComponent PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)
      | Just [AvailableTarget (UnitId, ComponentName)]
ats <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageIdentifier
pkgid, ComponentName
cname)
                               AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageIdAndComponentName
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget)
      forall a b. (a -> b) -> a -> b
$ forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget [AvailableTarget (UnitId, ComponentName)]
ats

      | forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageIdentifier
pkgid AvailableTargetsMap PackageIdentifier
availableTargetsByPackageId
      = forall a b. a -> Either a b
Left (forall a. PackageIdentifier -> ComponentName -> TargetProblem a
TargetProblemNoSuchComponent PackageIdentifier
pkgid ComponentName
cname)

      | Bool
otherwise
      = forall a b. a -> Either a b
Left (forall a. PackageIdentifier -> TargetProblem a
TargetProblemNoSuchPackage PackageIdentifier
pkgid)

    checkTarget (TargetComponentUnknown PackageName
pkgname Either UnqualComponentName ComponentName
ecname SubComponentTarget
subtarget)
      | Just [AvailableTarget (UnitId, ComponentName)]
ats <- case Either UnqualComponentName ComponentName
ecname of
          Left UnqualComponentName
ucname ->
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageName
pkgname, UnqualComponentName
ucname)
                       AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndUnqualComponentName
          Right ComponentName
cname ->
            forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageName
pkgname, ComponentName
cname)
                       AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageNameAndComponentName
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget)
      forall a b. (a -> b) -> a -> b
$ forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget [AvailableTarget (UnitId, ComponentName)]
ats

      | forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pkgname AvailableTargetsMap PackageName
availableTargetsByPackageName
      = forall a b. a -> Either a b
Left (forall a.
PackageName
-> Either UnqualComponentName ComponentName -> TargetProblem a
TargetProblemUnknownComponent PackageName
pkgname Either UnqualComponentName ComponentName
ecname)

      | Bool
otherwise
      = forall a b. a -> Either a b
Left (forall a. PackageName -> TargetProblem a
TargetNotInProject PackageName
pkgname)

    checkTarget bt :: TargetSelector
bt@(TargetPackageNamed PackageName
pkgname Maybe ComponentKindFilter
mkfilter)
      | Just [AvailableTarget (UnitId, ComponentName)]
ats <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter)
                  forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname AvailableTargetsMap PackageName
availableTargetsByPackageName
      = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt
      forall a b. (a -> b) -> a -> b
$ [AvailableTarget (UnitId, ComponentName)]
ats

      | Just SourcePackageDb{ PackageIndex UnresolvedSourcePackage
packageIndex :: SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex } <- Maybe SourcePackageDb
mPkgDb
      , let pkg :: [UnresolvedSourcePackage]
pkg = forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
lookupPackageName PackageIndex UnresolvedSourcePackage
packageIndex PackageName
pkgname
      , Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedSourcePackage]
pkg)
      = forall a b. a -> Either a b
Left (forall a. PackageName -> TargetProblem a
TargetAvailableInIndex PackageName
pkgname)

      | Bool
otherwise
      = forall a b. a -> Either a b
Left (forall a. PackageName -> TargetProblem a
TargetNotInProject PackageName
pkgname)

    componentTargets :: SubComponentTarget
                     -> [(b, ComponentName)]
                     -> [(b, ComponentTarget)]
    componentTargets :: forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget =
      forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ComponentName
cname -> ComponentName -> SubComponentTarget -> ComponentTarget
ComponentTarget ComponentName
cname SubComponentTarget
subtarget))

    selectComponentTargets :: SubComponentTarget
                           -> [AvailableTarget k]
                           -> Either (TargetProblem err) [k]
    selectComponentTargets :: forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget =
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> a
NE.head) forall a b. b -> Either a b
Right
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. [Either e a] -> Either (NonEmpty e) [a]
checkErrors
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget SubComponentTarget
subtarget)

    checkErrors :: [Either e a] -> Either (NonEmpty e) [a]
    checkErrors :: forall e a. [Either e a] -> Either (NonEmpty e) [a]
checkErrors = (\([e]
es, [a]
xs) -> case [e]
es of { [] -> forall a b. b -> Either a b
Right [a]
xs; (e
e:[e]
es') -> forall a b. a -> Either a b
Left (e
eforall a. a -> [a] -> NonEmpty a
:|[e]
es') })
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [Either a b] -> ([a], [b])
partitionEithers


data AvailableTargetIndexes = AvailableTargetIndexes {
       AvailableTargetIndexes
-> AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageIdAndComponentName
         :: AvailableTargetsMap (PackageId, ComponentName),

       AvailableTargetIndexes -> AvailableTargetsMap PackageIdentifier
availableTargetsByPackageId
         :: AvailableTargetsMap PackageId,

       AvailableTargetIndexes -> AvailableTargetsMap PackageName
availableTargetsByPackageName
         :: AvailableTargetsMap PackageName,

       AvailableTargetIndexes
-> AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageNameAndComponentName
         :: AvailableTargetsMap (PackageName, ComponentName),

       AvailableTargetIndexes
-> AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndUnqualComponentName
         :: AvailableTargetsMap (PackageName, UnqualComponentName)
     }
type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]

-- We define a bunch of indexes to help 'resolveTargets' with resolving
-- 'TargetSelector's to specific 'UnitId's.
--
-- They are all derived from the 'availableTargets' index.
-- The 'availableTargetsByPackageIdAndComponentName' is just that main index,
-- while the others are derived by re-grouping on the index key.
--
-- They are all constructed lazily because they are not necessarily all used.
--
availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes
availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes
availableTargetIndexes ElaboratedInstallPlan
installPlan = AvailableTargetIndexes{AvailableTargetsMap (PackageIdentifier, ComponentName)
AvailableTargetsMap (PackageName, ComponentName)
AvailableTargetsMap (PackageName, UnqualComponentName)
AvailableTargetsMap PackageIdentifier
AvailableTargetsMap PackageName
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName)
..}
  where
    availableTargetsByPackageIdAndComponentName ::
      Map (PackageId, ComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageIdAndComponentName =
      ElaboratedInstallPlan
-> AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargets ElaboratedInstallPlan
installPlan

    availableTargetsByPackageId ::
      Map PackageId [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier
availableTargetsByPackageId =
                  forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
                    forall a. [a] -> [a] -> [a]
(++) (\(PackageIdentifier
pkgid, ComponentName
_cname) -> PackageIdentifier
pkgid)
                    AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageIdAndComponentName
      forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` forall {a}. Map PackageIdentifier [a]
availableTargetsEmptyPackages

    availableTargetsByPackageName ::
      Map PackageName [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageName =
      forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
        forall a. [a] -> [a] -> [a]
(++) forall pkg. Package pkg => pkg -> PackageName
packageName
        AvailableTargetsMap PackageIdentifier
availableTargetsByPackageId

    availableTargetsByPackageNameAndComponentName ::
      Map (PackageName, ComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageNameAndComponentName =
      forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
        forall a. [a] -> [a] -> [a]
(++) (\(PackageIdentifier
pkgid, ComponentName
cname) -> (forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid, ComponentName
cname))
        AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageIdAndComponentName

    availableTargetsByPackageNameAndUnqualComponentName ::
      Map (PackageName, UnqualComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndUnqualComponentName =
      forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
        forall a. [a] -> [a] -> [a]
(++) (\(PackageIdentifier
pkgid, ComponentName
cname) -> let pname :: PackageName
pname  = forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid
                                     cname' :: UnqualComponentName
cname' = PackageName -> ComponentName -> UnqualComponentName
unqualComponentName PackageName
pname ComponentName
cname
                                  in (PackageName
pname, UnqualComponentName
cname'))
        AvailableTargetsMap (PackageIdentifier, ComponentName)
availableTargetsByPackageIdAndComponentName
      where
        unqualComponentName ::
          PackageName -> ComponentName -> UnqualComponentName
        unqualComponentName :: PackageName -> ComponentName -> UnqualComponentName
unqualComponentName PackageName
pkgname =
            forall a. a -> Maybe a -> a
fromMaybe (PackageName -> UnqualComponentName
packageNameToUnqualComponentName PackageName
pkgname)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> Maybe UnqualComponentName
componentNameString

    -- Add in all the empty packages. These do not appear in the
    -- availableTargetsByComponent map, since that only contains
    -- components, so packages with no components are invisible from
    -- that perspective.  The empty packages need to be there for
    -- proper error reporting, so users can select the empty package
    -- and then we can report that it is empty, otherwise we falsely
    -- report there is no such package at all.
    availableTargetsEmptyPackages :: Map PackageIdentifier [a]
availableTargetsEmptyPackages =
      forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg, [])
        | InstallPlan.Configured ElaboratedConfiguredPackage
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
installPlan
        , case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
pkg of
            ElabComponent ElaboratedComponent
_ -> Bool
False
            ElabPackage   ElaboratedPackage
_ -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageDescription -> [Component]
pkgComponents (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg))
        ]

    --TODO: [research required] what if the solution has multiple
    --      versions of this package?
    --      e.g. due to setup deps or due to multiple independent sets
    --      of packages being built (e.g. ghc + ghcjs in a project)

filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind :: forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKindFilter
ckind = forall k.
(ComponentKindFilter -> Bool)
-> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKindWith (forall a. Eq a => a -> a -> Bool
== ComponentKindFilter
ckind)

filterTargetsKindWith :: (ComponentKind -> Bool)
                     -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKindWith :: forall k.
(ComponentKindFilter -> Bool)
-> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKindWith ComponentKindFilter -> Bool
p [AvailableTarget k]
ts =
    [ AvailableTarget k
t | t :: AvailableTarget k
t@(AvailableTarget PackageIdentifier
_ ComponentName
cname AvailableTargetStatus k
_ Bool
_) <- [AvailableTarget k]
ts
        , ComponentKindFilter -> Bool
p (ComponentName -> ComponentKindFilter
componentKind ComponentName
cname) ]

selectBuildableTargets :: [AvailableTarget k] -> [k]
selectBuildableTargets :: forall k. [AvailableTarget k] -> [k]
selectBuildableTargets = forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith (forall a b. a -> b -> a
const Bool
True)

zipBuildableTargetsWith :: (TargetRequested -> Bool)
                        -> [AvailableTarget k] -> [(k, AvailableTarget k)]
zipBuildableTargetsWith :: forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> [(k, AvailableTarget k)]
zipBuildableTargetsWith TargetRequested -> Bool
p [AvailableTarget k]
ts =
    [ (k
k, AvailableTarget k
t) | t :: AvailableTarget k
t@(AvailableTarget PackageIdentifier
_ ComponentName
_ (TargetBuildable k
k TargetRequested
req) Bool
_) <- [AvailableTarget k]
ts, TargetRequested -> Bool
p TargetRequested
req ]

selectBuildableTargetsWith :: (TargetRequested -> Bool)
                          -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith :: forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith TargetRequested -> Bool
p = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> [(k, AvailableTarget k)]
zipBuildableTargetsWith TargetRequested -> Bool
p

selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets' :: forall k. [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets' = forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith' (forall a b. a -> b -> a
const Bool
True)

selectBuildableTargetsWith' :: (TargetRequested -> Bool)
                           -> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith' :: forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith' TargetRequested -> Bool
p =
  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map) forall k. AvailableTarget k -> AvailableTarget ()
forgetTargetDetail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> [(k, AvailableTarget k)]
zipBuildableTargetsWith TargetRequested -> Bool
p


forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()
forgetTargetDetail :: forall k. AvailableTarget k -> AvailableTarget ()
forgetTargetDetail = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const ())

forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail :: forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail = forall a b. (a -> b) -> [a] -> [b]
map forall k. AvailableTarget k -> AvailableTarget ()
forgetTargetDetail

-- | A basic @selectComponentTarget@ implementation to use or pass to
-- 'resolveTargets', that does the basic checks that the component is
-- buildable and isn't a test suite or benchmark that is disabled. This
-- can also be used to do these basic checks as part of a custom impl that
--
selectComponentTargetBasic :: SubComponentTarget
                           -> AvailableTarget k
                           -> Either (TargetProblem a) k
selectComponentTargetBasic :: forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic SubComponentTarget
subtarget
                           AvailableTarget {
                             availableTargetPackageId :: forall k. AvailableTarget k -> PackageIdentifier
availableTargetPackageId     = PackageIdentifier
pkgid,
                             availableTargetComponentName :: forall k. AvailableTarget k -> ComponentName
availableTargetComponentName = ComponentName
cname,
                             AvailableTargetStatus k
availableTargetStatus :: forall k. AvailableTarget k -> AvailableTargetStatus k
availableTargetStatus :: AvailableTargetStatus k
availableTargetStatus
                           } =
    case AvailableTargetStatus k
availableTargetStatus of
      AvailableTargetStatus k
TargetDisabledByUser ->
        forall a b. a -> Either a b
Left (forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetOptionalStanzaDisabledByUser PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)

      AvailableTargetStatus k
TargetDisabledBySolver ->
        forall a b. a -> Either a b
Left (forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetOptionalStanzaDisabledBySolver PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)

      AvailableTargetStatus k
TargetNotLocal ->
        forall a b. a -> Either a b
Left (forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetComponentNotProjectLocal PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)

      AvailableTargetStatus k
TargetNotBuildable ->
        forall a b. a -> Either a b
Left (forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetComponentNotBuildable PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)

      TargetBuildable k
targetKey TargetRequested
_ ->
        forall a b. b -> Either a b
Right k
targetKey

-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts
-- for the extra unneeded info in the 'TargetsMap'.
--
pruneInstallPlanToTargets :: TargetAction -> TargetsMap
                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets :: TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets TargetAction
targetActionType TargetsMap
targetsMap ElaboratedInstallPlan
elaboratedPlan =
    forall a. (?callStack::CallStack) => Bool -> a -> a
assert (forall k a. Map k a -> Int
Map.size TargetsMap
targetsMap forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$
    TargetAction
-> Map UnitId [ComponentTarget]
-> ElaboratedInstallPlan
-> ElaboratedInstallPlan
ProjectPlanning.pruneInstallPlanToTargets
      TargetAction
targetActionType
      (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) TargetsMap
targetsMap)
      ElaboratedInstallPlan
elaboratedPlan

-- | Utility used by repl and run to check if the targets spans multiple
-- components, since those commands do not support multiple components.
--
distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName)
distinctTargetComponents :: TargetsMap -> Set (UnitId, ComponentName)
distinctTargetComponents TargetsMap
targetsMap =
    forall a. Ord a => [a] -> Set a
Set.fromList [ (UnitId
uid, ComponentName
cname)
                 | (UnitId
uid, [(ComponentTarget, NonEmpty TargetSelector)]
cts) <- forall k a. Map k a -> [(k, a)]
Map.toList TargetsMap
targetsMap
                 , (ComponentTarget ComponentName
cname SubComponentTarget
_, NonEmpty TargetSelector
_) <- [(ComponentTarget, NonEmpty TargetSelector)]
cts ]


------------------------------------------------------------------------------
-- Displaying what we plan to do
--

-- | Print a user-oriented presentation of the install plan, indicating what
-- will be built.
--
printPlan :: Verbosity
          -> ProjectBaseContext
          -> ProjectBuildContext
          -> IO ()
printPlan :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity
          ProjectBaseContext {
            buildSettings :: ProjectBaseContext -> BuildTimeSettings
buildSettings = BuildTimeSettings{Bool
buildSettingDryRun :: Bool
buildSettingDryRun :: BuildTimeSettings -> Bool
buildSettingDryRun},
            projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig = ProjectConfig {
              projectConfigAllPackages :: ProjectConfig -> PackageConfig
projectConfigAllPackages =
                  PackageConfig {packageConfigOptimization :: PackageConfig -> Flag OptimisationLevel
packageConfigOptimization = Flag OptimisationLevel
globalOptimization},
              projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages =
                  PackageConfig {packageConfigOptimization :: PackageConfig -> Flag OptimisationLevel
packageConfigOptimization = Flag OptimisationLevel
localOptimization}
            },
            CurrentCommand
currentCommand :: CurrentCommand
currentCommand :: ProjectBaseContext -> CurrentCommand
currentCommand
          }
          ProjectBuildContext {
            elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute = ElaboratedInstallPlan
elaboratedPlan,
            ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared,
            BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
pkgsBuildStatus
          }
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs Bool -> Bool -> Bool
&& CurrentCommand
currentCommand forall a. Eq a => a -> a -> Bool
== CurrentCommand
BuildCommand
    = Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Up to date"
  | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs) = Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
      (String
showBuildProfile forall a. [a] -> [a] -> [a]
++ String
"In order, the following "
       forall a. [a] -> [a] -> [a]
++ String
wouldWill forall a. [a] -> [a] -> [a]
++ String
" be built"
       forall a. [a] -> [a] -> [a]
++ ShowS
ifNormal String
" (use -v for more details)" forall a. [a] -> [a] -> [a]
++ String
":")
    forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map GenericReadyPackage ElaboratedConfiguredPackage -> String
showPkgAndReason [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    pkgs :: [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs = forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg]
InstallPlan.executionOrder ElaboratedInstallPlan
elaboratedPlan

    ifVerbose :: ShowS
ifVerbose String
s | Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose = String
s
                | Bool
otherwise            = String
""

    ifNormal :: ShowS
ifNormal String
s | Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose = String
""
               | Bool
otherwise            = String
s

    wouldWill :: String
wouldWill | Bool
buildSettingDryRun = String
"would"
              | Bool
otherwise          = String
"will"

    showPkgAndReason :: ElaboratedReadyPackage -> String
    showPkgAndReason :: GenericReadyPackage ElaboratedConfiguredPackage -> String
showPkgAndReason (ReadyPackage ElaboratedConfiguredPackage
elab) = [String] -> String
unwords forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) forall a b. (a -> b) -> a -> b
$
      [ String
" -"
      , if Verbosity
verbosity forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening
        then forall a. Pretty a => a -> String
prettyShow (forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
elab)
        else forall a. Pretty a => a -> String
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
elab)
      , case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
elab of
          ElabPackage ElaboratedPackage
pkg -> ElaboratedConfiguredPackage -> String
showTargets ElaboratedConfiguredPackage
elab forall a. [a] -> [a] -> [a]
++ ShowS
ifVerbose (OptionalStanzaSet -> String
showStanzas (ElaboratedPackage -> OptionalStanzaSet
pkgStanzasEnabled ElaboratedPackage
pkg))
          ElabComponent ElaboratedComponent
comp ->
            String
"(" forall a. [a] -> [a] -> [a]
++ ElaboratedConfiguredPackage -> ElaboratedComponent -> String
showComp ElaboratedConfiguredPackage
elab ElaboratedComponent
comp forall a. [a] -> [a] -> [a]
++ String
")"
      , FlagAssignment -> String
showFlagAssignment (ElaboratedConfiguredPackage -> FlagAssignment
nonDefaultFlags ElaboratedConfiguredPackage
elab)
      , ElaboratedConfiguredPackage -> String
showConfigureFlags ElaboratedConfiguredPackage
elab
      , let buildStatus :: BuildStatus
buildStatus = BuildStatusMap
pkgsBuildStatus forall k a. Ord k => Map k a -> k -> a
Map.! forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
elab
        in String
"(" forall a. [a] -> [a] -> [a]
++ BuildStatus -> String
showBuildStatus BuildStatus
buildStatus forall a. [a] -> [a] -> [a]
++ String
")"
      ]

    showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
    showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
showComp ElaboratedConfiguredPackage
elab ElaboratedComponent
comp =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"custom" forall a. Pretty a => a -> String
prettyShow (ElaboratedComponent -> Maybe ComponentName
compComponentName ElaboratedComponent
comp) forall a. [a] -> [a] -> [a]
++
        if forall k a. Map k a -> Bool
Map.null (ElaboratedConfiguredPackage -> Map ModuleName Module
elabInstantiatedWith ElaboratedConfiguredPackage
elab)
            then String
""
            else String
" with " forall a. [a] -> [a] -> [a]
++
                forall a. [a] -> [[a]] -> [a]
intercalate String
", "
                    -- TODO: Abbreviate the UnitIds
                    [ forall a. Pretty a => a -> String
prettyShow ModuleName
k forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow Module
v
                    | (ModuleName
k,Module
v) <- forall k a. Map k a -> [(k, a)]
Map.toList (ElaboratedConfiguredPackage -> Map ModuleName Module
elabInstantiatedWith ElaboratedConfiguredPackage
elab) ]

    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
    nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
nonDefaultFlags ElaboratedConfiguredPackage
elab =
      ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment ElaboratedConfiguredPackage
elab FlagAssignment -> FlagAssignment -> FlagAssignment
`diffFlagAssignment` ElaboratedConfiguredPackage -> FlagAssignment
elabFlagDefaults ElaboratedConfiguredPackage
elab

    showTargets :: ElaboratedConfiguredPackage -> String
    showTargets :: ElaboratedConfiguredPackage -> String
showTargets ElaboratedConfiguredPackage
elab
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets ElaboratedConfiguredPackage
elab) = String
""
      | Bool
otherwise
      = String
"("
        forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ PackageIdentifier -> ComponentTarget -> String
showComponentTarget (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
elab) ComponentTarget
t
                            | ComponentTarget
t <- ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets ElaboratedConfiguredPackage
elab ]
        forall a. [a] -> [a] -> [a]
++ String
")"

    showConfigureFlags :: ElaboratedConfiguredPackage -> String
    showConfigureFlags :: ElaboratedConfiguredPackage -> String
showConfigureFlags ElaboratedConfiguredPackage
elab =
        let fullConfigureFlags :: ConfigFlags
fullConfigureFlags
              = GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedSharedConfig -> Verbosity -> String -> ConfigFlags
setupHsConfigureFlags
                    (forall srcpkg. srcpkg -> GenericReadyPackage srcpkg
ReadyPackage ElaboratedConfiguredPackage
elab)
                    ElaboratedSharedConfig
elaboratedShared
                    Verbosity
verbosity
                    String
"$builddir"
            -- | Given a default value @x@ for a flag, nub @Flag x@
            -- into @NoFlag@.  This gives us a tidier command line
            -- rendering.
            nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a
            nubFlag :: forall a. Eq a => a -> Flag a -> Flag a
nubFlag a
x (Setup.Flag a
x') | a
x forall a. Eq a => a -> a -> Bool
== a
x' = forall a. Flag a
Setup.NoFlag
            nubFlag a
_ Flag a
f                         = Flag a
f

            (Bool
tryLibProfiling, Bool
tryExeProfiling) =
              ConfigFlags -> (Bool, Bool)
computeEffectiveProfiling ConfigFlags
fullConfigureFlags

            partialConfigureFlags :: ConfigFlags
partialConfigureFlags
              = forall a. Monoid a => a
mempty {
                configProf :: Flag Bool
configProf    =
                    forall a. Eq a => a -> Flag a -> Flag a
nubFlag Bool
False (ConfigFlags -> Flag Bool
configProf ConfigFlags
fullConfigureFlags),
                configProfExe :: Flag Bool
configProfExe =
                    forall a. Eq a => a -> Flag a -> Flag a
nubFlag Bool
tryExeProfiling (ConfigFlags -> Flag Bool
configProfExe ConfigFlags
fullConfigureFlags),
                configProfLib :: Flag Bool
configProfLib =
                    forall a. Eq a => a -> Flag a -> Flag a
nubFlag Bool
tryLibProfiling (ConfigFlags -> Flag Bool
configProfLib ConfigFlags
fullConfigureFlags)
                -- Maybe there are more we can add
              }
        -- Not necessary to "escape" it, it's just for user output
        in [String] -> String
unwords forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
""forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$
            forall flags. CommandUI flags -> flags -> [String]
commandShowOptions
            (ProgramDb -> CommandUI ConfigFlags
Setup.configureCommand (ElaboratedSharedConfig -> ProgramDb
pkgConfigCompilerProgs ElaboratedSharedConfig
elaboratedShared))
            ConfigFlags
partialConfigureFlags

    showBuildStatus :: BuildStatus -> String
    showBuildStatus :: BuildStatus -> String
showBuildStatus BuildStatus
status = case BuildStatus
status of
      BuildStatus
BuildStatusPreExisting -> String
"existing package"
      BuildStatus
BuildStatusInstalled   -> String
"already installed"
      BuildStatusDownload {} -> String
"requires download & build"
      BuildStatusUnpack   {} -> String
"requires build"
      BuildStatusRebuild String
_ BuildStatusRebuild
rebuild -> case BuildStatusRebuild
rebuild of
        BuildStatusConfigure
          (MonitoredValueChanged ()
_)   -> String
"configuration changed"
        BuildStatusConfigure MonitorChangedReason ()
mreason  -> forall a. MonitorChangedReason a -> String
showMonitorChangedReason MonitorChangedReason ()
mreason
        BuildStatusBuild Maybe (Maybe InstalledPackageInfo)
_ BuildReason
buildreason -> case BuildReason
buildreason of
          BuildReason
BuildReasonDepsRebuilt      -> String
"dependency rebuilt"
          BuildReasonFilesChanged
            MonitorChangedReason ()
mreason                   -> forall a. MonitorChangedReason a -> String
showMonitorChangedReason MonitorChangedReason ()
mreason
          BuildReasonExtraTargets Set ComponentName
_   -> String
"additional components to build"
          BuildReason
BuildReasonEphemeralTargets -> String
"ephemeral targets"
      BuildStatusUpToDate {} -> String
"up to date" -- doesn't happen

    showMonitorChangedReason :: MonitorChangedReason a -> String
    showMonitorChangedReason :: forall a. MonitorChangedReason a -> String
showMonitorChangedReason (MonitoredFileChanged String
file) =
      String
"file " forall a. [a] -> [a] -> [a]
++ String
file forall a. [a] -> [a] -> [a]
++ String
" changed"
    showMonitorChangedReason (MonitoredValueChanged a
_)   = String
"value changed"
    showMonitorChangedReason  MonitorChangedReason a
MonitorFirstRun            = String
"first run"
    showMonitorChangedReason  MonitorChangedReason a
MonitorCorruptCache        =
      String
"cannot read state cache"

    showBuildProfile :: String
    showBuildProfile :: String
showBuildProfile = String
"Build profile: " forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [
      String
"-w " forall a. [a] -> [a] -> [a]
++ (Compiler -> String
showCompilerId forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> Compiler
pkgConfigCompiler) ElaboratedSharedConfig
elaboratedShared,
      String
"-O" forall a. [a] -> [a] -> [a]
++  (case Flag OptimisationLevel
globalOptimization forall a. Semigroup a => a -> a -> a
<> Flag OptimisationLevel
localOptimization of -- if local is not set, read global
                Setup.Flag OptimisationLevel
NoOptimisation      -> String
"0"
                Setup.Flag OptimisationLevel
NormalOptimisation  -> String
"1"
                Setup.Flag OptimisationLevel
MaximumOptimisation -> String
"2"
                Flag OptimisationLevel
Setup.NoFlag                   -> String
"1")]
      forall a. [a] -> [a] -> [a]
++ String
"\n"


writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
writeBuildReports :: BuildTimeSettings
-> ProjectBuildContext
-> ElaboratedInstallPlan
-> BuildOutcomes
-> IO ()
writeBuildReports BuildTimeSettings
settings ProjectBuildContext
buildContext ElaboratedInstallPlan
plan BuildOutcomes
buildOutcomes = do
  let plat :: Platform
plat@(Platform Arch
arch OS
os) = ElaboratedSharedConfig -> Platform
pkgConfigPlatform forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared forall a b. (a -> b) -> a -> b
$ ProjectBuildContext
buildContext
      comp :: Compiler
comp = ElaboratedSharedConfig -> Compiler
pkgConfigCompiler forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared forall a b. (a -> b) -> a -> b
$ ProjectBuildContext
buildContext
      getRepo :: PackageLocation local -> Maybe Repo
getRepo (RepoTarballPackage Repo
r PackageIdentifier
_ local
_) = forall a. a -> Maybe a
Just Repo
r
      getRepo PackageLocation local
_ = forall a. Maybe a
Nothing
      fromPlanPackage :: GenericPlanPackage ipkg ElaboratedConfiguredPackage
-> Maybe BuildOutcome -> Maybe (BuildReport, Maybe Repo)
fromPlanPackage (InstallPlan.Configured ElaboratedConfiguredPackage
pkg) (Just BuildOutcome
result) =
            let installOutcome :: InstallOutcome
installOutcome = case BuildOutcome
result of
                   Left BuildFailure
bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                      DependentFailed PackageIdentifier
p -> PackageIdentifier -> InstallOutcome
BuildReports.DependencyFailed PackageIdentifier
p
                      DownloadFailed SomeException
_  -> InstallOutcome
BuildReports.DownloadFailed
                      UnpackFailed SomeException
_ -> InstallOutcome
BuildReports.UnpackFailed
                      ConfigureFailed SomeException
_ -> InstallOutcome
BuildReports.ConfigureFailed
                      BuildFailed SomeException
_ -> InstallOutcome
BuildReports.BuildFailed
                      TestsFailed SomeException
_ -> InstallOutcome
BuildReports.TestsFailed
                      InstallFailed SomeException
_ -> InstallOutcome
BuildReports.InstallFailed

                      ReplFailed SomeException
_ -> InstallOutcome
BuildReports.InstallOk
                      HaddocksFailed SomeException
_ -> InstallOutcome
BuildReports.InstallOk
                      BenchFailed SomeException
_ -> InstallOutcome
BuildReports.InstallOk

                   Right BuildResult
_br -> InstallOutcome
BuildReports.InstallOk

                docsOutcome :: Outcome
docsOutcome = case BuildOutcome
result of
                   Left BuildFailure
bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                      HaddocksFailed SomeException
_ -> Outcome
BuildReports.Failed
                      BuildFailureReason
_ -> Outcome
BuildReports.NotTried
                   Right BuildResult
br -> case BuildResult -> DocsResult
buildResultDocs BuildResult
br of
                      DocsResult
DocsNotTried -> Outcome
BuildReports.NotTried
                      DocsResult
DocsFailed -> Outcome
BuildReports.Failed
                      DocsResult
DocsOk -> Outcome
BuildReports.Ok

                testsOutcome :: Outcome
testsOutcome = case BuildOutcome
result of
                   Left BuildFailure
bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                      TestsFailed SomeException
_ -> Outcome
BuildReports.Failed
                      BuildFailureReason
_ -> Outcome
BuildReports.NotTried
                   Right BuildResult
br -> case BuildResult -> TestsResult
buildResultTests BuildResult
br of
                      TestsResult
TestsNotTried -> Outcome
BuildReports.NotTried
                      TestsResult
TestsOk -> Outcome
BuildReports.Ok

            in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (PackageIdentifier
-> OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> InstallOutcome
-> Outcome
-> Outcome
-> BuildReport
BuildReports.BuildReport (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg) OS
os Arch
arch (Compiler -> CompilerId
compilerId Compiler
comp) PackageIdentifier
cabalInstallID (ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment ElaboratedConfiguredPackage
pkg) (forall a b. (a -> b) -> [a] -> [b]
map forall pkg. Package pkg => pkg -> PackageIdentifier
packageId forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> [ConfiguredId]
elabLibDependencies ElaboratedConfiguredPackage
pkg) InstallOutcome
installOutcome Outcome
docsOutcome Outcome
testsOutcome, forall {local}. PackageLocation local -> Maybe Repo
getRepo forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> PackageLocation (Maybe String)
elabPkgSourceLocation forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage
pkg) -- TODO handle failure log files?
      fromPlanPackage GenericPlanPackage ipkg ElaboratedConfiguredPackage
_ Maybe BuildOutcome
_ = forall a. Maybe a
Nothing
      buildReports :: [(BuildReport, Maybe Repo)]
buildReports = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x -> forall {ipkg}.
GenericPlanPackage ipkg ElaboratedConfiguredPackage
-> Maybe BuildOutcome -> Maybe (BuildReport, Maybe Repo)
fromPlanPackage GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x (forall pkg failure result.
HasUnitId pkg =>
pkg
-> BuildOutcomes failure result -> Maybe (Either failure result)
InstallPlan.lookupBuildOutcome GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x BuildOutcomes
buildOutcomes)) forall a b. (a -> b) -> a -> b
$ forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan


  CompilerInfo
-> [PathTemplate]
-> [(BuildReport, Maybe Repo)]
-> Platform
-> IO ()
BuildReports.storeLocal (Compiler -> CompilerInfo
compilerInfo Compiler
comp)
                          (BuildTimeSettings -> [PathTemplate]
buildSettingSummaryFile BuildTimeSettings
settings)
                          [(BuildReport, Maybe Repo)]
buildReports
                          Platform
plat
  -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1
  -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle.

-- | If there are build failures then report them and throw an exception.
--
dieOnBuildFailures :: Verbosity -> CurrentCommand
                   -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
dieOnBuildFailures :: Verbosity
-> CurrentCommand
-> ElaboratedInstallPlan
-> BuildOutcomes
-> IO ()
dieOnBuildFailures Verbosity
verbosity CurrentCommand
currentCommand ElaboratedInstallPlan
plan BuildOutcomes
buildOutcomes
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, BuildFailure)]
failures = forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | Bool
isSimpleCase  = forall a. IO a
exitFailure

  | Bool
otherwise = do
      -- For failures where we have a build log, print the log plus a header
       forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
         [ do Verbosity -> String -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
                Char
'\n' forall a. a -> [a] -> [a]
: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail Bool
False ElaboratedConfiguredPackage
pkg BuildFailureReason
reason
                    forall a. [a] -> [a] -> [a]
++ String
"\nBuild log ( " forall a. [a] -> [a] -> [a]
++ String
logfile forall a. [a] -> [a] -> [a]
++ String
" ):"
              String -> IO String
readFile String
logfile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity
         | (ElaboratedConfiguredPackage
pkg, ShowBuildSummaryAndLog BuildFailureReason
reason String
logfile)
             <- [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
failuresClassification
         ]

       -- For all failures, print either a short summary (if we showed the
       -- build log) or all details
       Verbosity -> String -> IO ()
dieIfNotHaddockFailure Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
         [ case BuildFailurePresentation
failureClassification of
             ShowBuildSummaryAndLog BuildFailureReason
reason String
_
               | Verbosity
verbosity forall a. Ord a => a -> a -> Bool
> Verbosity
normal
              -> Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail Bool
mentionDepOf ElaboratedConfiguredPackage
pkg BuildFailureReason
reason

               | Bool
otherwise
              -> Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureSummary Bool
mentionDepOf ElaboratedConfiguredPackage
pkg BuildFailureReason
reason
              forall a. [a] -> [a] -> [a]
++ String
". See the build log above for details."

             ShowBuildSummaryOnly BuildFailureReason
reason ->
               Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail Bool
mentionDepOf ElaboratedConfiguredPackage
pkg BuildFailureReason
reason

         | let mentionDepOf :: Bool
mentionDepOf = Verbosity
verbosity forall a. Ord a => a -> a -> Bool
<= Verbosity
normal
         , (ElaboratedConfiguredPackage
pkg, BuildFailurePresentation
failureClassification) <- [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
failuresClassification ]
  where
    failures :: [(UnitId, BuildFailure)]
    failures :: [(UnitId, BuildFailure)]
failures =  [ (UnitId
pkgid, BuildFailure
failure)
                | (UnitId
pkgid, Left BuildFailure
failure) <- forall k a. Map k a -> [(k, a)]
Map.toList BuildOutcomes
buildOutcomes ]

    failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
    failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
failuresClassification =
      [ (ElaboratedConfiguredPackage
pkg, BuildFailure -> BuildFailurePresentation
classifyBuildFailure BuildFailure
failure)
      | (UnitId
pkgid, BuildFailure
failure) <- [(UnitId, BuildFailure)]
failures
      , case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
failure of
          DependentFailed {} -> Verbosity
verbosity forall a. Ord a => a -> a -> Bool
> Verbosity
normal
          BuildFailureReason
_                  -> Bool
True
      , InstallPlan.Configured ElaboratedConfiguredPackage
pkg <-
           forall a. Maybe a -> [a]
maybeToList (forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg
-> UnitId -> Maybe (GenericPlanPackage ipkg srcpkg)
InstallPlan.lookup ElaboratedInstallPlan
plan UnitId
pkgid)
      ]

    dieIfNotHaddockFailure :: Verbosity -> String -> IO ()
    dieIfNotHaddockFailure :: Verbosity -> String -> IO ()
dieIfNotHaddockFailure
      | CurrentCommand
currentCommand forall a. Eq a => a -> a -> Bool
== CurrentCommand
HaddockCommand            = forall a. Verbosity -> String -> IO a
die'
      | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {a}. (a, BuildFailurePresentation) -> Bool
isHaddockFailure [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
failuresClassification = Verbosity -> String -> IO ()
warn
      | Bool
otherwise                                   = forall a. Verbosity -> String -> IO a
die'
      where
        isHaddockFailure :: (a, BuildFailurePresentation) -> Bool
isHaddockFailure
          (a
_, ShowBuildSummaryOnly   (HaddocksFailed SomeException
_)  ) = Bool
True
        isHaddockFailure
          (a
_, ShowBuildSummaryAndLog (HaddocksFailed SomeException
_) String
_) = Bool
True
        isHaddockFailure
          (a, BuildFailurePresentation)
_                                                = Bool
False


    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
classifyBuildFailure BuildFailure {
                           buildFailureReason :: BuildFailure -> BuildFailureReason
buildFailureReason  = BuildFailureReason
reason,
                           buildFailureLogFile :: BuildFailure -> Maybe String
buildFailureLogFile = Maybe String
mlogfile
                         } =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BuildFailureReason -> BuildFailurePresentation
ShowBuildSummaryOnly   BuildFailureReason
reason)
            (BuildFailureReason -> String -> BuildFailurePresentation
ShowBuildSummaryAndLog BuildFailureReason
reason) forall a b. (a -> b) -> a -> b
$ do
        String
logfile <- Maybe String
mlogfile
        SomeException
e       <- BuildFailureReason -> Maybe SomeException
buildFailureException BuildFailureReason
reason
        ExitFailure Int
1 <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
        forall (m :: * -> *) a. Monad m => a -> m a
return String
logfile

    -- Special case: we don't want to report anything complicated in the case
    -- of just doing build on the current package, since it's clear from
    -- context which package failed.
    --
    -- We generalise this rule as follows:
    --  - if only one failure occurs, and it is in a single root
    --    package (i.e. a package with nothing else depending on it)
    --  - and that failure is of a kind that always reports enough
    --    detail itself (e.g. ghc reporting errors on stdout)
    --  - then we do not report additional error detail or context.
    --
    isSimpleCase :: Bool
    isSimpleCase :: Bool
isSimpleCase
      | [(UnitId
pkgid, BuildFailure
failure)] <- [(UnitId, BuildFailure)]
failures
      , [ElaboratedConfiguredPackage
pkg]              <- [ElaboratedConfiguredPackage]
rootpkgs
      , forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg forall a. Eq a => a -> a -> Bool
== UnitId
pkgid
      , BuildFailureReason -> Bool
isFailureSelfExplanatory (BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
failure)
      , CurrentCommand
currentCommand forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CurrentCommand
InstallCommand, CurrentCommand
BuildCommand, CurrentCommand
ReplCommand]
      = Bool
True
      | Bool
otherwise
      = Bool
False

    -- NB: if the Setup script segfaulted or was interrupted,
    -- we should give more detailed information.  So only
    -- assume that exit code 1 is "pedestrian failure."
    isFailureSelfExplanatory :: BuildFailureReason -> Bool
    isFailureSelfExplanatory :: BuildFailureReason -> Bool
isFailureSelfExplanatory (BuildFailed SomeException
e)
      | Just (ExitFailure Int
1) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True

    isFailureSelfExplanatory (ConfigureFailed SomeException
e)
      | Just (ExitFailure Int
1) <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True

    isFailureSelfExplanatory BuildFailureReason
_                  = Bool
False

    rootpkgs :: [ElaboratedConfiguredPackage]
    rootpkgs :: [ElaboratedConfiguredPackage]
rootpkgs =
      [ ElaboratedConfiguredPackage
pkg
      | InstallPlan.Configured ElaboratedConfiguredPackage
pkg <- forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
      , forall pkg. HasUnitId pkg => pkg -> Bool
hasNoDependents ElaboratedConfiguredPackage
pkg ]

    ultimateDeps
      :: UnitId
      -> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage]
    ultimateDeps :: UnitId
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
ultimateDeps UnitId
pkgid =
        forall a. (a -> Bool) -> [a] -> [a]
filter (\GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
pkg -> forall pkg. HasUnitId pkg => pkg -> Bool
hasNoDependents GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
pkg Bool -> Bool -> Bool
&& forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
pkg forall a. Eq a => a -> a -> Bool
/= UnitId
pkgid)
               (forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> [UnitId] -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.reverseDependencyClosure ElaboratedInstallPlan
plan [UnitId
pkgid])

    hasNoDependents :: HasUnitId pkg => pkg -> Bool
    hasNoDependents :: forall pkg. HasUnitId pkg => pkg -> Bool
hasNoDependents = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.revDirectDeps ElaboratedInstallPlan
plan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId

    renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
    renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail Bool
mentionDepOf ElaboratedConfiguredPackage
pkg BuildFailureReason
reason =
        Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureSummary Bool
mentionDepOf ElaboratedConfiguredPackage
pkg BuildFailureReason
reason forall a. [a] -> [a] -> [a]
++ String
"."
     forall a. [a] -> [a] -> [a]
++ BuildFailureReason -> String
renderFailureExtraDetail BuildFailureReason
reason
     forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" SomeException -> String
showException (BuildFailureReason -> Maybe SomeException
buildFailureException BuildFailureReason
reason)

    renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
    renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureSummary Bool
mentionDepOf ElaboratedConfiguredPackage
pkg BuildFailureReason
reason =
        case BuildFailureReason
reason of
          DownloadFailed  SomeException
_ -> String
"Failed to download " forall a. [a] -> [a] -> [a]
++ String
pkgstr
          UnpackFailed    SomeException
_ -> String
"Failed to unpack "   forall a. [a] -> [a] -> [a]
++ String
pkgstr
          ConfigureFailed SomeException
_ -> String
"Failed to build "    forall a. [a] -> [a] -> [a]
++ String
pkgstr
          BuildFailed     SomeException
_ -> String
"Failed to build "    forall a. [a] -> [a] -> [a]
++ String
pkgstr
          ReplFailed      SomeException
_ -> String
"repl failed for "    forall a. [a] -> [a] -> [a]
++ String
pkgstr
          HaddocksFailed  SomeException
_ -> String
"Failed to build documentation for " forall a. [a] -> [a] -> [a]
++ String
pkgstr
          TestsFailed     SomeException
_ -> String
"Tests failed for " forall a. [a] -> [a] -> [a]
++ String
pkgstr
          BenchFailed     SomeException
_ -> String
"Benchmarks failed for " forall a. [a] -> [a] -> [a]
++ String
pkgstr
          InstallFailed   SomeException
_ -> String
"Failed to build "  forall a. [a] -> [a] -> [a]
++ String
pkgstr
          DependentFailed PackageIdentifier
depid
                            -> String
"Failed to build " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow (forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg)
                            forall a. [a] -> [a] -> [a]
++ String
" because it depends on " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> String
prettyShow PackageIdentifier
depid
                            forall a. [a] -> [a] -> [a]
++ String
" which itself failed to build"
      where
        pkgstr :: String
pkgstr = Verbosity -> ElaboratedConfiguredPackage -> String
elabConfiguredName Verbosity
verbosity ElaboratedConfiguredPackage
pkg
              forall a. [a] -> [a] -> [a]
++ if Bool
mentionDepOf
                   then UnitId -> String
renderDependencyOf (forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg)
                   else String
""

    renderFailureExtraDetail :: BuildFailureReason -> String
    renderFailureExtraDetail :: BuildFailureReason -> String
renderFailureExtraDetail (ConfigureFailed SomeException
_) =
      String
" The failure occurred during the configure step."
    renderFailureExtraDetail (InstallFailed   SomeException
_) =
      String
" The failure occurred during the final install step."
    renderFailureExtraDetail BuildFailureReason
_                   =
      String
""

    renderDependencyOf :: UnitId -> String
    renderDependencyOf :: UnitId -> String
renderDependencyOf UnitId
pkgid =
      case UnitId
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
ultimateDeps UnitId
pkgid of
        []         -> String
""
        (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1:[])    ->
          String
" (which is required by " forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1 forall a. [a] -> [a] -> [a]
++ String
")"
        (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1:GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2:[]) ->
          String
" (which is required by " forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1
          forall a. [a] -> [a] -> [a]
++ String
" and " forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2 forall a. [a] -> [a] -> [a]
++ String
")"
        (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1:GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2:[GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage]
_)  ->
          String
" (which is required by " forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1
          forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2
          forall a. [a] -> [a] -> [a]
++ String
" and others)"

    showException :: SomeException -> String
showException SomeException
e = case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (ExitFailure Int
1) -> String
""

#ifdef MIN_VERSION_unix
      -- Note [Positive "signal" exit code]
      -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
      -- What's the business with the test for negative and positive
      -- signal values?  The API for process specifies that if the
      -- process died due to a signal, it returns a *negative* exit
      -- code.  So that's the negative test.
      --
      -- What about the positive test?  Well, when we find out that
      -- a process died due to a signal, we ourselves exit with that
      -- exit code.  However, we don't "kill ourselves" with the
      -- signal; we just exit with the same code as the signal: thus
      -- the caller sees a *positive* exit code.  So that's what
      -- happens when we get a positive exit code.
      Just (ExitFailure Int
n)
        | -Int
n forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
sigSEGV ->
            String
" The build process segfaulted (i.e. SIGSEGV)."

        |  Int
n forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
sigSEGV ->
            String
" The build process terminated with exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
         forall a. [a] -> [a] -> [a]
++ String
" which may be because some part of it segfaulted. (i.e. SIGSEGV)."

        | -Int
n forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
sigKILL ->
            String
" The build process was killed (i.e. SIGKILL). " forall a. [a] -> [a] -> [a]
++ String
explanation

        |  Int
n forall a. Eq a => a -> a -> Bool
== forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
sigKILL ->
            String
" The build process terminated with exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
         forall a. [a] -> [a] -> [a]
++ String
" which may be because some part of it was killed "
         forall a. [a] -> [a] -> [a]
++ String
"(i.e. SIGKILL). " forall a. [a] -> [a] -> [a]
++ String
explanation
        where
          explanation :: String
explanation =
            String
"The typical reason for this is that there is not "
            forall a. [a] -> [a] -> [a]
++ String
"enough memory available (e.g. the OS killed a process "
            forall a. [a] -> [a] -> [a]
++ String
"using lots of memory)."
#endif
      Just (ExitFailure Int
n) ->
        String
" The build process terminated with exit code " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n

      Maybe ExitCode
_ -> String
" The exception was:\n  "
#if MIN_VERSION_base(4,8,0)
             forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException SomeException
e
#else
             ++ show e
#endif

    buildFailureException :: BuildFailureReason -> Maybe SomeException
    buildFailureException :: BuildFailureReason -> Maybe SomeException
buildFailureException BuildFailureReason
reason =
      case BuildFailureReason
reason of
        DownloadFailed  SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        UnpackFailed    SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        ConfigureFailed SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        BuildFailed     SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        ReplFailed      SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        HaddocksFailed  SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        TestsFailed     SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        BenchFailed     SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        InstallFailed   SomeException
e -> forall a. a -> Maybe a
Just SomeException
e
        DependentFailed PackageIdentifier
_ -> forall a. Maybe a
Nothing

data BuildFailurePresentation =
       ShowBuildSummaryOnly   BuildFailureReason
     | ShowBuildSummaryAndLog BuildFailureReason FilePath

-------------------------------------------------------------------------------
-- Dummy projects
-------------------------------------------------------------------------------

-- | Create a dummy project context, without a .cabal or a .cabal.project file
-- (a place where to put a temporary dist directory is still needed)
establishDummyProjectBaseContext
  :: Verbosity
  -> ProjectConfig
     -- ^ Project configuration including the global config if needed
  -> DistDirLayout
     -- ^ Where to put the dist directory
  -> [PackageSpecifier UnresolvedSourcePackage]
     -- ^ The packages to be included in the project
  -> CurrentCommand
  -> IO ProjectBaseContext
establishDummyProjectBaseContext :: Verbosity
-> ProjectConfig
-> DistDirLayout
-> [PackageSpecifier UnresolvedSourcePackage]
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext Verbosity
verbosity ProjectConfig
projectConfig DistDirLayout
distDirLayout [PackageSpecifier UnresolvedSourcePackage]
localPackages CurrentCommand
currentCommand = do
    let ProjectConfigBuildOnly {
          Flag String
projectConfigLogsDir :: Flag String
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag String
projectConfigLogsDir
        } = ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
projectConfig

        ProjectConfigShared {
          Flag String
projectConfigStoreDir :: Flag String
projectConfigStoreDir :: ProjectConfigShared -> Flag String
projectConfigStoreDir
        } = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
projectConfig

        mlogsDir :: Maybe String
mlogsDir = forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigLogsDir
        mstoreDir :: Maybe String
mstoreDir = forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigStoreDir

    CabalDirLayout
cabalDirLayout <- Maybe String -> Maybe String -> IO CabalDirLayout
mkCabalDirLayout Maybe String
mstoreDir Maybe String
mlogsDir

    let buildSettings :: BuildTimeSettings
        buildSettings :: BuildTimeSettings
buildSettings = Verbosity -> CabalDirLayout -> ProjectConfig -> BuildTimeSettings
resolveBuildTimeSettings
                          Verbosity
verbosity CabalDirLayout
cabalDirLayout
                          ProjectConfig
projectConfig
        installedPackages :: Maybe a
installedPackages = forall a. Maybe a
Nothing

    forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext {
      DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout,
      CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout,
      ProjectConfig
projectConfig :: ProjectConfig
projectConfig :: ProjectConfig
projectConfig,
      [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages,
      BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings,
      CurrentCommand
currentCommand :: CurrentCommand
currentCommand :: CurrentCommand
currentCommand,
      forall a. Maybe a
installedPackages :: forall a. Maybe a
installedPackages :: Maybe InstalledPackageIndex
installedPackages
    }

establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> String -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity ProjectConfig
cliConfig String
tmpDir = do
    let distDirLayout :: DistDirLayout
distDirLayout = ProjectRoot -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory

    -- Create the dist directories
    Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True forall a b. (a -> b) -> a -> b
$ DistDirLayout -> String
distDirectory DistDirLayout
distDirLayout
    Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True forall a b. (a -> b) -> a -> b
$ DistDirLayout -> String
distProjectCacheDirectory DistDirLayout
distDirLayout

    forall (m :: * -> *) a. Monad m => a -> m a
return DistDirLayout
distDirLayout
  where
    mdistDirectory :: Maybe String
mdistDirectory = forall a. Flag a -> Maybe a
flagToMaybe
                   forall a b. (a -> b) -> a -> b
$ ProjectConfigShared -> Flag String
projectConfigDistDir
                   forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig
    projectRoot :: ProjectRoot
projectRoot = String -> ProjectRoot
ProjectRootImplicit String
tmpDir