{-# 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.Config (getCabalDir)
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.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 | OtherCommand
                    deriving (Int -> CurrentCommand -> ShowS
[CurrentCommand] -> ShowS
CurrentCommand -> String
(Int -> CurrentCommand -> ShowS)
-> (CurrentCommand -> String)
-> ([CurrentCommand] -> ShowS)
-> Show CurrentCommand
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
(CurrentCommand -> CurrentCommand -> Bool)
-> (CurrentCommand -> CurrentCommand -> Bool) -> Eq CurrentCommand
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
     }

establishProjectBaseContext
    :: Verbosity
    -> ProjectConfig
    -> CurrentCommand
    -> IO ProjectBaseContext
establishProjectBaseContext :: Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
currentCommand = do
    ProjectRoot
projectRoot <- (BadProjectRoot -> IO ProjectRoot)
-> (ProjectRoot -> IO ProjectRoot)
-> Either BadProjectRoot ProjectRoot
-> IO ProjectRoot
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either BadProjectRoot -> IO ProjectRoot
forall e a. Exception e => e -> IO a
throwIO ProjectRoot -> IO ProjectRoot
forall (m :: * -> *) a. Monad m => a -> m a
return (Either BadProjectRoot ProjectRoot -> IO ProjectRoot)
-> IO (Either BadProjectRoot ProjectRoot) -> IO ProjectRoot
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe String
-> Maybe String -> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Maybe String
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   = Flag String -> Maybe String
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
    String
cabalDir <- IO String
getCabalDir

    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
                     (NubList String -> [String]
forall a. NubList a -> [a]
fromNubList (NubList String -> [String])
-> (ProjectConfigShared -> NubList String)
-> ProjectConfigShared
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigShared -> NubList String
projectConfigProgPathExtra (ProjectConfigShared -> [String])
-> ProjectConfigShared -> [String]
forall a b. (a -> b) -> a -> b
$ ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
                     (Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (Flag String -> Maybe String)
-> (ProjectConfigBuildOnly -> Flag String)
-> ProjectConfigBuildOnly
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfigBuildOnly -> Flag String
projectConfigHttpTransport (ProjectConfigBuildOnly -> Maybe String)
-> ProjectConfigBuildOnly -> Maybe String
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 = Flag String -> Maybe String
forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigLogsDir
    Maybe String
mstoreDir <- Maybe (IO String) -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA (Maybe (IO String) -> IO (Maybe String))
-> Maybe (IO String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute
                 (String -> IO String) -> Maybe String -> Maybe (IO String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flag String -> Maybe String
forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigStoreDir
    let cabalDirLayout :: CabalDirLayout
cabalDirLayout = String -> Maybe String -> Maybe String -> CabalDirLayout
mkCabalDirLayout String
cabalDir Maybe String
mstoreDir Maybe String
mlogsDir

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

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

    ProjectBaseContext -> IO ProjectBaseContext
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext :: DistDirLayout
-> CabalDirLayout
-> ProjectConfig
-> [PackageSpecifier UnresolvedSourcePackage]
-> BuildTimeSettings
-> CurrentCommand
-> ProjectBaseContext
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
    }
  where
    mdistDirectory :: Maybe String
mdistDirectory = Flag String -> Maybe String
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


-- | 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 :: 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
    }
    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]
-> IO
     (ElaboratedInstallPlan, ElaboratedInstallPlan,
      ElaboratedSharedConfig, TotalIndexState, ActiveRepos)
rebuildInstallPlan Verbosity
verbosity
                         DistDirLayout
distDirLayout CabalDirLayout
cabalDirLayout
                         ProjectConfig
projectConfig
                         [PackageSpecifier UnresolvedSourcePackage]
localPackages
    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
    }
    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]
-> IO
     (ElaboratedInstallPlan, ElaboratedInstallPlan,
      ElaboratedSharedConfig, TotalIndexState, ActiveRepos)
rebuildInstallPlan Verbosity
verbosity
                         DistDirLayout
distDirLayout CabalDirLayout
cabalDirLayout
                         ProjectConfig
projectConfig
                         [PackageSpecifier UnresolvedSourcePackage]
localPackages

    -- 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 (ElaboratedInstallPlan -> String
forall ipkg srcpkg.
(Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> String
InstallPlan.showInstallPlan ElaboratedInstallPlan
elaboratedPlan'')

    ProjectBuildContext -> IO ProjectBuildContext
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBuildContext :: ElaboratedInstallPlan
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
-> TargetsMap
-> ProjectBuildContext
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
  = BuildOutcomes -> IO BuildOutcomes
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcomes
forall k a. Map k a
Map.empty

runProjectBuildPhase Verbosity
verbosity
                     ProjectBaseContext{[PackageSpecifier UnresolvedSourcePackage]
CabalDirLayout
DistDirLayout
BuildTimeSettings
ProjectConfig
CurrentCommand
currentCommand :: CurrentCommand
buildSettings :: BuildTimeSettings
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectConfig
cabalDirLayout :: CabalDirLayout
distDirLayout :: DistDirLayout
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
..} =
    (BuildOutcomes -> BuildOutcomes)
-> IO BuildOutcomes -> IO BuildOutcomes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BuildOutcomes -> BuildOutcomes -> BuildOutcomes
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (BuildStatusMap -> BuildOutcomes
previousBuildOutcomes BuildStatusMap
pkgsBuildStatus)) (IO BuildOutcomes -> IO BuildOutcomes)
-> IO BuildOutcomes -> IO BuildOutcomes
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 =
      (BuildStatus -> Maybe (Either BuildFailure BuildResult))
-> BuildStatusMap -> BuildOutcomes
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((BuildStatus -> Maybe (Either BuildFailure BuildResult))
 -> BuildStatusMap -> BuildOutcomes)
-> (BuildStatus -> Maybe (Either BuildFailure BuildResult))
-> BuildStatusMap
-> BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \BuildStatus
status -> case BuildStatus
status of
        BuildStatusUpToDate BuildResult
buildSuccess -> Either BuildFailure BuildResult
-> Maybe (Either BuildFailure BuildResult)
forall a. a -> Maybe a
Just (BuildResult -> Either BuildFailure BuildResult
forall a b. b -> Either a b
Right BuildResult
buildSuccess)
        --TODO: [nice to have] record build failures persistently
        BuildStatus
_                                  -> Maybe (Either BuildFailure BuildResult)
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
  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

runProjectPostBuildPhase Verbosity
verbosity
                         ProjectBaseContext {[PackageSpecifier UnresolvedSourcePackage]
CabalDirLayout
DistDirLayout
BuildTimeSettings
ProjectConfig
CurrentCommand
currentCommand :: CurrentCommand
buildSettings :: BuildTimeSettings
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
projectConfig :: ProjectConfig
cabalDirLayout :: CabalDirLayout
distDirLayout :: DistDirLayout
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 (ProjectConfigShared -> Flag WriteGhcEnvironmentFilesPolicy)
-> (ProjectConfig -> ProjectConfigShared)
-> ProjectConfig
-> Flag WriteGhcEnvironmentFilesPolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectConfig -> ProjectConfigShared
projectConfigShared
          (ProjectConfig -> Flag WriteGhcEnvironmentFilesPolicy)
-> ProjectConfig -> Flag WriteGhcEnvironmentFilesPolicy
forall a b. (a -> b) -> a -> b
$ ProjectConfig
projectConfig

        shouldWriteGhcEnvironment :: Bool
        shouldWriteGhcEnvironment :: Bool
shouldWriteGhcEnvironment =
          case WriteGhcEnvironmentFilesPolicy
-> Flag WriteGhcEnvironmentFilesPolicy
-> WriteGhcEnvironmentFilesPolicy
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 Bool -> (Version -> Bool) -> Maybe Version -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
8,Int
4,Int
4]) Maybe Version
ghcCompatVersion

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldWriteGhcEnvironment (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      IO (Maybe String) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe String) -> IO ()) -> IO (Maybe String) -> IO ()
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 = ((ComponentTarget, NonEmpty TargetSelector) -> [TargetSelector])
-> [(ComponentTarget, NonEmpty TargetSelector)] -> [TargetSelector]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (NonEmpty TargetSelector -> [TargetSelector]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty TargetSelector -> [TargetSelector])
-> ((ComponentTarget, NonEmpty TargetSelector)
    -> NonEmpty TargetSelector)
-> (ComponentTarget, NonEmpty TargetSelector)
-> [TargetSelector]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentTarget, NonEmpty TargetSelector)
-> NonEmpty TargetSelector
forall a b. (a, b) -> b
snd) ([(ComponentTarget, NonEmpty TargetSelector)] -> [TargetSelector])
-> (TargetsMap -> [(ComponentTarget, NonEmpty TargetSelector)])
-> TargetsMap
-> [TargetSelector]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[(ComponentTarget, NonEmpty TargetSelector)]]
-> [(ComponentTarget, NonEmpty TargetSelector)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(ComponentTarget, NonEmpty TargetSelector)]]
 -> [(ComponentTarget, NonEmpty TargetSelector)])
-> (TargetsMap -> [[(ComponentTarget, NonEmpty TargetSelector)]])
-> TargetsMap
-> [(ComponentTarget, NonEmpty TargetSelector)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetsMap -> [[(ComponentTarget, NonEmpty TargetSelector)]]
forall k a. Map k a -> [a]
Map.elems

-- | Get all unique target selectors.
uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
uniqueTargetSelectors :: TargetsMap -> [TargetSelector]
uniqueTargetSelectors = [TargetSelector] -> [TargetSelector]
forall a. Ord a => [a] -> [a]
ordNub ([TargetSelector] -> [TargetSelector])
-> (TargetsMap -> [TargetSelector])
-> TargetsMap
-> [TargetSelector]
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 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 =
      ([(TargetSelector, [(UnitId, ComponentTarget)])] -> TargetsMap)
-> Either
     [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
-> Either [TargetProblem err] TargetsMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(TargetSelector, [(UnitId, ComponentTarget)])] -> TargetsMap
mkTargetsMap
    (Either
   [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
 -> Either [TargetProblem err] TargetsMap)
-> ([TargetSelector]
    -> Either
         [TargetProblem err]
         [(TargetSelector, [(UnitId, ComponentTarget)])])
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (TargetProblem err)
 -> Either
      [TargetProblem err]
      [(TargetSelector, [(UnitId, ComponentTarget)])])
-> ([(TargetSelector, [(UnitId, ComponentTarget)])]
    -> Either
         [TargetProblem err]
         [(TargetSelector, [(UnitId, ComponentTarget)])])
-> Either
     (NonEmpty (TargetProblem err))
     [(TargetSelector, [(UnitId, ComponentTarget)])]
-> Either
     [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([TargetProblem err]
-> Either
     [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
forall a b. a -> Either a b
Left ([TargetProblem err]
 -> Either
      [TargetProblem err]
      [(TargetSelector, [(UnitId, ComponentTarget)])])
-> (NonEmpty (TargetProblem err) -> [TargetProblem err])
-> NonEmpty (TargetProblem err)
-> Either
     [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (TargetProblem err) -> [TargetProblem err]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) [(TargetSelector, [(UnitId, ComponentTarget)])]
-> Either
     [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
forall a b. b -> Either a b
Right
    (Either
   (NonEmpty (TargetProblem err))
   [(TargetSelector, [(UnitId, ComponentTarget)])]
 -> Either
      [TargetProblem err]
      [(TargetSelector, [(UnitId, ComponentTarget)])])
-> ([TargetSelector]
    -> Either
         (NonEmpty (TargetProblem err))
         [(TargetSelector, [(UnitId, ComponentTarget)])])
-> [TargetSelector]
-> Either
     [TargetProblem err] [(TargetSelector, [(UnitId, ComponentTarget)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either
   (TargetProblem err) (TargetSelector, [(UnitId, ComponentTarget)])]
-> Either
     (NonEmpty (TargetProblem err))
     [(TargetSelector, [(UnitId, ComponentTarget)])]
forall e a. [Either e a] -> Either (NonEmpty e) [a]
checkErrors
    ([Either
    (TargetProblem err) (TargetSelector, [(UnitId, ComponentTarget)])]
 -> Either
      (NonEmpty (TargetProblem err))
      [(TargetSelector, [(UnitId, ComponentTarget)])])
-> ([TargetSelector]
    -> [Either
          (TargetProblem err) (TargetSelector, [(UnitId, ComponentTarget)])])
-> [TargetSelector]
-> Either
     (NonEmpty (TargetProblem err))
     [(TargetSelector, [(UnitId, ComponentTarget)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TargetSelector
 -> Either
      (TargetProblem err) (TargetSelector, [(UnitId, ComponentTarget)]))
-> [TargetSelector]
-> [Either
      (TargetProblem err) (TargetSelector, [(UnitId, ComponentTarget)])]
forall a b. (a -> b) -> [a] -> [b]
map (\TargetSelector
ts -> (,) TargetSelector
ts ([(UnitId, ComponentTarget)]
 -> (TargetSelector, [(UnitId, ComponentTarget)]))
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
-> Either
     (TargetProblem err) (TargetSelector, [(UnitId, ComponentTarget)])
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 =
        ([(ComponentTarget, TargetSelector)]
 -> [(ComponentTarget, NonEmpty TargetSelector)])
-> Map UnitId [(ComponentTarget, TargetSelector)] -> TargetsMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [(ComponentTarget, TargetSelector)]
-> [(ComponentTarget, NonEmpty TargetSelector)]
forall a. [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)]
nubComponentTargets
      (Map UnitId [(ComponentTarget, TargetSelector)] -> TargetsMap)
-> Map UnitId [(ComponentTarget, TargetSelector)] -> TargetsMap
forall a b. (a -> b) -> a -> b
$ ([(ComponentTarget, TargetSelector)]
 -> [(ComponentTarget, TargetSelector)]
 -> [(ComponentTarget, TargetSelector)])
-> [(UnitId, [(ComponentTarget, TargetSelector)])]
-> Map UnitId [(ComponentTarget, TargetSelector)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(ComponentTarget, TargetSelector)]
-> [(ComponentTarget, TargetSelector)]
-> [(ComponentTarget, TargetSelector)]
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 (PackageId, ComponentName)
AvailableTargetsMap (PackageName, ComponentName)
AvailableTargetsMap (PackageName, UnqualComponentName)
AvailableTargetsMap PackageId
AvailableTargetsMap PackageName
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetIndexes
-> AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetIndexes
-> AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetIndexes -> AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetIndexes -> AvailableTargetsMap PackageId
availableTargetsByPackageIdAndComponentName :: AvailableTargetIndexes
-> AvailableTargetsMap (PackageId, ComponentName)
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetsMap PackageId
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageId, 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
_ [PackageId
pkgid] Maybe ComponentKindFilter
mkfilter)
      | Just [AvailableTarget (UnitId, ComponentName)]
ats <- ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> Maybe [AvailableTarget (UnitId, ComponentName)]
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> (ComponentKindFilter
    -> [AvailableTarget (UnitId, ComponentName)]
    -> [AvailableTarget (UnitId, ComponentName)])
-> Maybe ComponentKindFilter
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall a. a -> a
id ComponentKindFilter
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter)
                  (Maybe [AvailableTarget (UnitId, ComponentName)]
 -> Maybe [AvailableTarget (UnitId, ComponentName)])
-> Maybe [AvailableTarget (UnitId, ComponentName)]
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall a b. (a -> b) -> a -> b
$ PackageId
-> AvailableTargetsMap PackageId
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageId
pkgid AvailableTargetsMap PackageId
availableTargetsByPackageId
      = ([(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)])
-> Either (TargetProblem err) [(UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
      (Either (TargetProblem err) [(UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentTarget)])
-> Either (TargetProblem err) [(UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$ TargetSelector
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentName)]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt [AvailableTarget (UnitId, ComponentName)]
ats

      | Bool
otherwise
      = TargetProblem err
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageId -> TargetProblem err
forall a. PackageId -> TargetProblem a
TargetProblemNoSuchPackage PackageId
pkgid)

    checkTarget (TargetPackage TargetImplicitCwd
_ [PackageId]
pkgids Maybe ComponentKindFilter
_)
      = String -> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a. HasCallStack => String -> a
error (String
"TODO: add support for multiple packages in a directory.  Got\n"
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((PackageId -> String) -> [PackageId] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageId -> String
forall a. Pretty a => a -> String
prettyShow [PackageId]
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) =
        ([(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)])
-> Either (TargetProblem err) [(UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
      (Either (TargetProblem err) [(UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentTarget)])
-> ([AvailableTarget (UnitId, ComponentName)]
    -> Either (TargetProblem err) [(UnitId, ComponentName)])
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSelector
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentName)]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt
      ([AvailableTarget (UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentName)])
-> ([AvailableTarget (UnitId, ComponentName)]
    -> [AvailableTarget (UnitId, ComponentName)])
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> (ComponentKindFilter
    -> [AvailableTarget (UnitId, ComponentName)]
    -> [AvailableTarget (UnitId, ComponentName)])
-> Maybe ComponentKindFilter
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall a. a -> a
id ComponentKindFilter
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter
      ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> ([AvailableTarget (UnitId, ComponentName)]
    -> [AvailableTarget (UnitId, ComponentName)])
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AvailableTarget (UnitId, ComponentName) -> Bool)
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall a. (a -> Bool) -> [a] -> [a]
filter AvailableTarget (UnitId, ComponentName) -> Bool
forall k. AvailableTarget k -> Bool
availableTargetLocalToProject
      ([AvailableTarget (UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentTarget)])
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$ [[AvailableTarget (UnitId, ComponentName)]]
-> [AvailableTarget (UnitId, ComponentName)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (AvailableTargetsMap PackageId
-> [[AvailableTarget (UnitId, ComponentName)]]
forall k a. Map k a -> [a]
Map.elems AvailableTargetsMap PackageId
availableTargetsByPackageId)

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

      | PackageId -> AvailableTargetsMap PackageId -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageId
pkgid AvailableTargetsMap PackageId
availableTargetsByPackageId
      = TargetProblem err
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageId -> ComponentName -> TargetProblem err
forall a. PackageId -> ComponentName -> TargetProblem a
TargetProblemNoSuchComponent PackageId
pkgid ComponentName
cname)

      | Bool
otherwise
      = TargetProblem err
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageId -> TargetProblem err
forall a. PackageId -> TargetProblem a
TargetProblemNoSuchPackage PackageId
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 ->
            (PackageName, UnqualComponentName)
-> AvailableTargetsMap (PackageName, UnqualComponentName)
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageName
pkgname, UnqualComponentName
ucname)
                       AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndUnqualComponentName
          Right ComponentName
cname ->
            (PackageName, ComponentName)
-> AvailableTargetsMap (PackageName, ComponentName)
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (PackageName
pkgname, ComponentName
cname)
                       AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageNameAndComponentName
      = ([(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)])
-> Either (TargetProblem err) [(UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget)
      (Either (TargetProblem err) [(UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentTarget)])
-> Either (TargetProblem err) [(UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$ SubComponentTarget
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentName)]
forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget [AvailableTarget (UnitId, ComponentName)]
ats

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

      | Bool
otherwise
      = TargetProblem err
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageName -> TargetProblem err
forall a. PackageName -> TargetProblem a
TargetNotInProject PackageName
pkgname)

    checkTarget bt :: TargetSelector
bt@(TargetPackageNamed PackageName
pkgname Maybe ComponentKindFilter
mkfilter)
      | Just [AvailableTarget (UnitId, ComponentName)]
ats <- ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> Maybe [AvailableTarget (UnitId, ComponentName)]
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> (ComponentKindFilter
    -> [AvailableTarget (UnitId, ComponentName)]
    -> [AvailableTarget (UnitId, ComponentName)])
-> Maybe ComponentKindFilter
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall a. a -> a
id ComponentKindFilter
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter)
                  (Maybe [AvailableTarget (UnitId, ComponentName)]
 -> Maybe [AvailableTarget (UnitId, ComponentName)])
-> Maybe [AvailableTarget (UnitId, ComponentName)]
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall a b. (a -> b) -> a -> b
$ PackageName
-> AvailableTargetsMap PackageName
-> Maybe [AvailableTarget (UnitId, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname AvailableTargetsMap PackageName
availableTargetsByPackageName
      = ([(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)])
-> Either (TargetProblem err) [(UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(UnitId, ComponentName)] -> [(UnitId, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
      (Either (TargetProblem err) [(UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentTarget)])
-> ([AvailableTarget (UnitId, ComponentName)]
    -> Either (TargetProblem err) [(UnitId, ComponentName)])
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSelector
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentName)]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt
      ([AvailableTarget (UnitId, ComponentName)]
 -> Either (TargetProblem err) [(UnitId, ComponentTarget)])
-> [AvailableTarget (UnitId, ComponentName)]
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
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 = PackageIndex UnresolvedSourcePackage
-> PackageName -> [UnresolvedSourcePackage]
forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
lookupPackageName PackageIndex UnresolvedSourcePackage
packageIndex PackageName
pkgname
      , Bool -> Bool
not ([UnresolvedSourcePackage] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedSourcePackage]
pkg)
      = TargetProblem err
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageName -> TargetProblem err
forall a. PackageName -> TargetProblem a
TargetAvailableInIndex PackageName
pkgname)

      | Bool
otherwise
      = TargetProblem err
-> Either (TargetProblem err) [(UnitId, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageName -> TargetProblem err
forall a. PackageName -> TargetProblem a
TargetNotInProject PackageName
pkgname)

    componentTargets :: SubComponentTarget
                     -> [(b, ComponentName)]
                     -> [(b, ComponentTarget)]
    componentTargets :: SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget =
      ((b, ComponentName) -> (b, ComponentTarget))
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
forall a b. (a -> b) -> [a] -> [b]
map ((ComponentName -> ComponentTarget)
-> (b, ComponentName) -> (b, ComponentTarget)
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 :: SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget =
        (NonEmpty (TargetProblem err) -> Either (TargetProblem err) [k])
-> ([k] -> Either (TargetProblem err) [k])
-> Either (NonEmpty (TargetProblem err)) [k]
-> Either (TargetProblem err) [k]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TargetProblem err -> Either (TargetProblem err) [k]
forall a b. a -> Either a b
Left (TargetProblem err -> Either (TargetProblem err) [k])
-> (NonEmpty (TargetProblem err) -> TargetProblem err)
-> NonEmpty (TargetProblem err)
-> Either (TargetProblem err) [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (TargetProblem err) -> TargetProblem err
forall a. NonEmpty a -> a
NE.head) [k] -> Either (TargetProblem err) [k]
forall a b. b -> Either a b
Right
      (Either (NonEmpty (TargetProblem err)) [k]
 -> Either (TargetProblem err) [k])
-> ([AvailableTarget k]
    -> Either (NonEmpty (TargetProblem err)) [k])
-> [AvailableTarget k]
-> Either (TargetProblem err) [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either (TargetProblem err) k]
-> Either (NonEmpty (TargetProblem err)) [k]
forall e a. [Either e a] -> Either (NonEmpty e) [a]
checkErrors
      ([Either (TargetProblem err) k]
 -> Either (NonEmpty (TargetProblem err)) [k])
-> ([AvailableTarget k] -> [Either (TargetProblem err) k])
-> [AvailableTarget k]
-> Either (NonEmpty (TargetProblem err)) [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AvailableTarget k -> Either (TargetProblem err) k)
-> [AvailableTarget k] -> [Either (TargetProblem err) k]
forall a b. (a -> b) -> [a] -> [b]
map (SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget SubComponentTarget
subtarget)

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


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

       AvailableTargetIndexes -> AvailableTargetsMap PackageId
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 (PackageId, ComponentName)
-> AvailableTargetsMap PackageId
-> AvailableTargetsMap PackageName
-> AvailableTargetsMap (PackageName, ComponentName)
-> AvailableTargetsMap (PackageName, UnqualComponentName)
-> AvailableTargetIndexes
AvailableTargetIndexes{AvailableTargetsMap (PackageId, ComponentName)
AvailableTargetsMap (PackageName, ComponentName)
AvailableTargetsMap (PackageName, UnqualComponentName)
AvailableTargetsMap PackageId
AvailableTargetsMap PackageName
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetsMap PackageId
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageId, ComponentName)
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName)
availableTargetsByPackageName :: AvailableTargetsMap PackageName
availableTargetsByPackageId :: AvailableTargetsMap PackageId
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageId, ComponentName)
..}
  where
    availableTargetsByPackageIdAndComponentName ::
      Map (PackageId, ComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageId, ComponentName)
availableTargetsByPackageIdAndComponentName =
      ElaboratedInstallPlan
-> AvailableTargetsMap (PackageId, ComponentName)
availableTargets ElaboratedInstallPlan
installPlan

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

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

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

    availableTargetsByPackageNameAndUnqualComponentName ::
      Map (PackageName, UnqualComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName)
availableTargetsByPackageNameAndUnqualComponentName =
      ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> ((PackageId, ComponentName)
    -> (PackageName, UnqualComponentName))
-> AvailableTargetsMap (PackageId, ComponentName)
-> AvailableTargetsMap (PackageName, UnqualComponentName)
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
        [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
-> [AvailableTarget (UnitId, ComponentName)]
forall a. [a] -> [a] -> [a]
(++) (\(PackageId
pkgid, ComponentName
cname) -> let pname :: PackageName
pname  = PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pkgid
                                     cname' :: UnqualComponentName
cname' = PackageName -> ComponentName -> UnqualComponentName
unqualComponentName PackageName
pname ComponentName
cname
                                  in (PackageName
pname, UnqualComponentName
cname'))
        AvailableTargetsMap (PackageId, ComponentName)
availableTargetsByPackageIdAndComponentName
      where
        unqualComponentName ::
          PackageName -> ComponentName -> UnqualComponentName
        unqualComponentName :: PackageName -> ComponentName -> UnqualComponentName
unqualComponentName PackageName
pkgname =
            UnqualComponentName
-> Maybe UnqualComponentName -> UnqualComponentName
forall a. a -> Maybe a -> a
fromMaybe (PackageName -> UnqualComponentName
packageNameToUnqualComponentName PackageName
pkgname)
          (Maybe UnqualComponentName -> UnqualComponentName)
-> (ComponentName -> Maybe UnqualComponentName)
-> ComponentName
-> UnqualComponentName
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 PackageId [a]
availableTargetsEmptyPackages =
      [(PackageId, [a])] -> Map PackageId [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
pkg, [])
        | InstallPlan.Configured ElaboratedConfiguredPackage
pkg <- ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
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
_ -> [Component] -> Bool
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 :: ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKindFilter
ckind = (ComponentKindFilter -> Bool)
-> [AvailableTarget k] -> [AvailableTarget k]
forall k.
(ComponentKindFilter -> Bool)
-> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKindWith (ComponentKindFilter -> ComponentKindFilter -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKindFilter
ckind)

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

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

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

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

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

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


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

forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail = (AvailableTarget k -> AvailableTarget ())
-> [AvailableTarget k] -> [AvailableTarget ()]
forall a b. (a -> b) -> [a] -> [b]
map AvailableTarget k -> AvailableTarget ()
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 :: SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic SubComponentTarget
subtarget
                           AvailableTarget {
                             availableTargetPackageId :: forall k. AvailableTarget k -> PackageId
availableTargetPackageId     = PackageId
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 ->
        TargetProblem a -> Either (TargetProblem a) k
forall a b. a -> Either a b
Left (PackageId -> ComponentName -> SubComponentTarget -> TargetProblem a
forall a.
PackageId -> ComponentName -> SubComponentTarget -> TargetProblem a
TargetOptionalStanzaDisabledByUser PackageId
pkgid ComponentName
cname SubComponentTarget
subtarget)

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

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

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

      TargetBuildable k
targetKey TargetRequested
_ ->
        k -> Either (TargetProblem a) k
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 =
    Bool -> ElaboratedInstallPlan -> ElaboratedInstallPlan
forall a. HasCallStack => Bool -> a -> a
assert (TargetsMap -> Int
forall k a. Map k a -> Int
Map.size TargetsMap
targetsMap Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (ElaboratedInstallPlan -> ElaboratedInstallPlan)
-> ElaboratedInstallPlan -> ElaboratedInstallPlan
forall a b. (a -> b) -> a -> b
$
    TargetAction
-> Map UnitId [ComponentTarget]
-> ElaboratedInstallPlan
-> ElaboratedInstallPlan
ProjectPlanning.pruneInstallPlanToTargets
      TargetAction
targetActionType
      (([(ComponentTarget, NonEmpty TargetSelector)] -> [ComponentTarget])
-> TargetsMap -> Map UnitId [ComponentTarget]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (((ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget)
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [ComponentTarget]
forall a b. (a -> b) -> [a] -> [b]
map (ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget
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 =
    [(UnitId, ComponentName)] -> Set (UnitId, ComponentName)
forall a. Ord a => [a] -> Set a
Set.fromList [ (UnitId
uid, ComponentName
cname)
                 | (UnitId
uid, [(ComponentTarget, NonEmpty TargetSelector)]
cts) <- TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
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 {
              projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages =
                  PackageConfig {Flag OptimisationLevel
packageConfigOptimization :: PackageConfig -> Flag OptimisationLevel
packageConfigOptimization :: Flag OptimisationLevel
packageConfigOptimization}
            }
          }
          ProjectBuildContext {
            elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute = ElaboratedInstallPlan
elaboratedPlan,
            ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared,
            BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
pkgsBuildStatus
          }

  | [GenericReadyPackage ElaboratedConfiguredPackage] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs
  = Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Up to date"

  | Bool
otherwise
  = Verbosity -> String -> IO ()
noticeNoWrap Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
      (String
showBuildProfile String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"In order, the following "
       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
wouldWill String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" be built"
       String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
ifNormal String
" (use -v for more details)" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":")
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (GenericReadyPackage ElaboratedConfiguredPackage -> String)
-> [GenericReadyPackage ElaboratedConfiguredPackage] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GenericReadyPackage ElaboratedConfiguredPackage -> String
showPkgAndReason [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs

  where
    pkgs :: [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs = ElaboratedInstallPlan
-> [GenericReadyPackage ElaboratedConfiguredPackage]
forall ipkg srcpkg.
(IsUnit ipkg, IsUnit srcpkg) =>
GenericInstallPlan ipkg srcpkg -> [GenericReadyPackage srcpkg]
InstallPlan.executionOrder ElaboratedInstallPlan
elaboratedPlan

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

    ifNormal :: ShowS
ifNormal String
s | Verbosity
verbosity Verbosity -> Verbosity -> Bool
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 ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
      [ String
" -"
      , if Verbosity
verbosity Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
deafening
        then UnitId -> String
forall a. Pretty a => a -> String
prettyShow (ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
elab)
        else PackageId -> String
forall a. Pretty a => a -> String
prettyShow (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
elab)
      , case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
elab of
          ElabPackage ElaboratedPackage
pkg -> ElaboratedConfiguredPackage -> String
showTargets ElaboratedConfiguredPackage
elab String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
ifVerbose (OptionalStanzaSet -> String
showStanzas (ElaboratedPackage -> OptionalStanzaSet
pkgStanzasEnabled ElaboratedPackage
pkg))
          ElabComponent ElaboratedComponent
comp ->
            String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ElaboratedConfiguredPackage -> ElaboratedComponent -> String
showComp ElaboratedConfiguredPackage
elab ElaboratedComponent
comp String -> ShowS
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 BuildStatusMap -> UnitId -> BuildStatus
forall k a. Ord k => Map k a -> k -> a
Map.! ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
elab
        in String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BuildStatus -> String
showBuildStatus BuildStatus
buildStatus String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
      ]

    showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
    showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
showComp ElaboratedConfiguredPackage
elab ElaboratedComponent
comp =
        String
-> (ComponentName -> String) -> Maybe ComponentName -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"custom" ComponentName -> String
forall a. Pretty a => a -> String
prettyShow (ElaboratedComponent -> Maybe ComponentName
compComponentName ElaboratedComponent
comp) String -> ShowS
forall a. [a] -> [a] -> [a]
++
        if Map ModuleName Module -> Bool
forall k a. Map k a -> Bool
Map.null (ElaboratedConfiguredPackage -> Map ModuleName Module
elabInstantiatedWith ElaboratedConfiguredPackage
elab)
            then String
""
            else String
" with " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
                    -- TODO: Abbreviate the UnitIds
                    [ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Module -> String
forall a. Pretty a => a -> String
prettyShow Module
v
                    | (ModuleName
k,Module
v) <- Map ModuleName Module -> [(ModuleName, Module)]
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
      | [ComponentTarget] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets ElaboratedConfiguredPackage
elab) = String
""
      | Bool
otherwise
      = String
"("
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [ PackageId -> ComponentTarget -> String
showComponentTarget (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
elab) ComponentTarget
t
                            | ComponentTarget
t <- ElaboratedConfiguredPackage -> [ComponentTarget]
elabBuildTargets ElaboratedConfiguredPackage
elab ]
        String -> ShowS
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
                    (ElaboratedConfiguredPackage
-> GenericReadyPackage ElaboratedConfiguredPackage
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 :: a -> Flag a -> Flag a
nubFlag a
x (Setup.Flag a
x') | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x' = Flag a
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
              = ConfigFlags
forall a. Monoid a => a
mempty {
                configProf :: Flag Bool
configProf    =
                    Bool -> Flag Bool -> Flag Bool
forall a. Eq a => a -> Flag a -> Flag a
nubFlag Bool
False (ConfigFlags -> Flag Bool
configProf ConfigFlags
fullConfigureFlags),
                configProfExe :: Flag Bool
configProfExe =
                    Bool -> Flag Bool -> Flag Bool
forall a. Eq a => a -> Flag a -> Flag a
nubFlag Bool
tryExeProfiling (ConfigFlags -> Flag Bool
configProfExe ConfigFlags
fullConfigureFlags),
                configProfLib :: Flag Bool
configProfLib =
                    Bool -> Flag Bool -> Flag Bool
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 ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
""String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            CommandUI ConfigFlags -> ConfigFlags -> [String]
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  -> MonitorChangedReason () -> String
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                   -> MonitorChangedReason () -> String
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 :: MonitorChangedReason a -> String
showMonitorChangedReason (MonitoredFileChanged String
file) =
      String
"file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
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: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [
      String
"-w " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Compiler -> String
showCompilerId (Compiler -> String)
-> (ElaboratedSharedConfig -> Compiler)
-> ElaboratedSharedConfig
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedSharedConfig -> Compiler
pkgConfigCompiler) ElaboratedSharedConfig
elaboratedShared,
      String
"-O" String -> ShowS
forall a. [a] -> [a] -> [a]
++  (case Flag OptimisationLevel
packageConfigOptimization of
                Setup.Flag OptimisationLevel
NoOptimisation      -> String
"0"
                Setup.Flag OptimisationLevel
NormalOptimisation  -> String
"1"
                Setup.Flag OptimisationLevel
MaximumOptimisation -> String
"2"
                Flag OptimisationLevel
Setup.NoFlag                   -> String
"1")]
      String -> ShowS
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 (ElaboratedSharedConfig -> Platform)
-> (ProjectBuildContext -> ElaboratedSharedConfig)
-> ProjectBuildContext
-> Platform
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared (ProjectBuildContext -> Platform)
-> ProjectBuildContext -> Platform
forall a b. (a -> b) -> a -> b
$ ProjectBuildContext
buildContext
      comp :: Compiler
comp = ElaboratedSharedConfig -> Compiler
pkgConfigCompiler (ElaboratedSharedConfig -> Compiler)
-> (ProjectBuildContext -> ElaboratedSharedConfig)
-> ProjectBuildContext
-> Compiler
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared (ProjectBuildContext -> Compiler)
-> ProjectBuildContext -> Compiler
forall a b. (a -> b) -> a -> b
$ ProjectBuildContext
buildContext
      getRepo :: PackageLocation local -> Maybe Repo
getRepo (RepoTarballPackage Repo
r PackageId
_ local
_) = Repo -> Maybe Repo
forall a. a -> Maybe a
Just Repo
r
      getRepo PackageLocation local
_ = Maybe Repo
forall a. Maybe a
Nothing
      fromPlanPackage :: GenericPlanPackage ipkg ElaboratedConfiguredPackage
-> Maybe (Either BuildFailure BuildResult)
-> Maybe (BuildReport, Maybe Repo)
fromPlanPackage (InstallPlan.Configured ElaboratedConfiguredPackage
pkg) (Just Either BuildFailure BuildResult
result) =
            let installOutcome :: InstallOutcome
installOutcome = case Either BuildFailure BuildResult
result of
                   Left bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                      DependentFailed PackageId
p -> PackageId -> InstallOutcome
BuildReports.DependencyFailed PackageId
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 _br -> InstallOutcome
BuildReports.InstallOk

                docsOutcome :: Outcome
docsOutcome = case Either BuildFailure BuildResult
result of
                   Left bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                      HaddocksFailed SomeException
_ -> Outcome
BuildReports.Failed
                      BuildFailureReason
_ -> Outcome
BuildReports.NotTried
                   Right 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 Either BuildFailure BuildResult
result of
                   Left bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                      TestsFailed SomeException
_ -> Outcome
BuildReports.Failed
                      BuildFailureReason
_ -> Outcome
BuildReports.NotTried
                   Right br -> case BuildResult -> TestsResult
buildResultTests BuildResult
br of
                      TestsResult
TestsNotTried -> Outcome
BuildReports.NotTried
                      TestsResult
TestsOk -> Outcome
BuildReports.Ok

            in (BuildReport, Maybe Repo) -> Maybe (BuildReport, Maybe Repo)
forall a. a -> Maybe a
Just ((BuildReport, Maybe Repo) -> Maybe (BuildReport, Maybe Repo))
-> (BuildReport, Maybe Repo) -> Maybe (BuildReport, Maybe Repo)
forall a b. (a -> b) -> a -> b
$ (PackageId
-> OS
-> Arch
-> CompilerId
-> PackageId
-> FlagAssignment
-> [PackageId]
-> InstallOutcome
-> Outcome
-> Outcome
-> BuildReport
BuildReports.BuildReport (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
pkg) OS
os Arch
arch (Compiler -> CompilerId
compilerId Compiler
comp) PackageId
cabalInstallID (ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment ElaboratedConfiguredPackage
pkg) ((ConfiguredId -> PackageId) -> [ConfiguredId] -> [PackageId]
forall a b. (a -> b) -> [a] -> [b]
map ConfiguredId -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ([ConfiguredId] -> [PackageId]) -> [ConfiguredId] -> [PackageId]
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> [ConfiguredId]
elabLibDependencies ElaboratedConfiguredPackage
pkg) InstallOutcome
installOutcome Outcome
docsOutcome Outcome
testsOutcome, PackageLocation (Maybe String) -> Maybe Repo
forall local. PackageLocation local -> Maybe Repo
getRepo (PackageLocation (Maybe String) -> Maybe Repo)
-> (ElaboratedConfiguredPackage -> PackageLocation (Maybe String))
-> ElaboratedConfiguredPackage
-> Maybe Repo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedConfiguredPackage -> PackageLocation (Maybe String)
elabPkgSourceLocation (ElaboratedConfiguredPackage -> Maybe Repo)
-> ElaboratedConfiguredPackage -> Maybe Repo
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage
pkg) -- TODO handle failure log files?
      fromPlanPackage GenericPlanPackage ipkg ElaboratedConfiguredPackage
_ Maybe (Either BuildFailure BuildResult)
_ = Maybe (BuildReport, Maybe Repo)
forall a. Maybe a
Nothing
      buildReports :: [(BuildReport, Maybe Repo)]
buildReports = (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> Maybe (BuildReport, Maybe Repo))
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [(BuildReport, Maybe Repo)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x -> GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> Maybe (Either BuildFailure BuildResult)
-> Maybe (BuildReport, Maybe Repo)
forall ipkg.
GenericPlanPackage ipkg ElaboratedConfiguredPackage
-> Maybe (Either BuildFailure BuildResult)
-> Maybe (BuildReport, Maybe Repo)
fromPlanPackage GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> BuildOutcomes -> Maybe (Either BuildFailure BuildResult)
forall pkg failure result.
HasUnitId pkg =>
pkg
-> BuildOutcomes failure result -> Maybe (Either failure result)
InstallPlan.lookupBuildOutcome GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x BuildOutcomes
buildOutcomes)) ([GenericPlanPackage
    InstalledPackageInfo ElaboratedConfiguredPackage]
 -> [(BuildReport, Maybe Repo)])
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [(BuildReport, Maybe Repo)]
forall a b. (a -> b) -> a -> b
$ ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
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
  | [(UnitId, BuildFailure)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, BuildFailure)]
failures = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  | Bool
isSimpleCase  = IO ()
forall a. IO a
exitFailure

  | Bool
otherwise = do
      -- For failures where we have a build log, print the log plus a header
       [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
         [ do Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail Bool
False ElaboratedConfiguredPackage
pkg BuildFailureReason
reason
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nBuild log ( " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
logfile String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ):"
              String -> IO String
readFile String
logfile IO String -> (String -> IO ()) -> IO ()
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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
         [ case BuildFailurePresentation
failureClassification of
             ShowBuildSummaryAndLog BuildFailureReason
reason String
_
               | Verbosity
verbosity Verbosity -> Verbosity -> Bool
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
              String -> ShowS
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 Verbosity -> Verbosity -> Bool
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) <- BuildOutcomes -> [(UnitId, Either BuildFailure BuildResult)]
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 Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
normal
          BuildFailureReason
_                  -> Bool
True
      , InstallPlan.Configured ElaboratedConfiguredPackage
pkg <-
           Maybe
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall a. Maybe a -> [a]
maybeToList (ElaboratedInstallPlan
-> UnitId
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
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 CurrentCommand -> CurrentCommand -> Bool
forall a. Eq a => a -> a -> Bool
== CurrentCommand
HaddockCommand            = Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die'
      | ((ElaboratedConfiguredPackage, BuildFailurePresentation) -> Bool)
-> [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ElaboratedConfiguredPackage, BuildFailurePresentation) -> Bool
forall a. (a, BuildFailurePresentation) -> Bool
isHaddockFailure [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
failuresClassification = Verbosity -> String -> IO ()
warn
      | Bool
otherwise                                   = Verbosity -> String -> IO ()
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
                         } =
      BuildFailurePresentation
-> (String -> BuildFailurePresentation)
-> Maybe String
-> BuildFailurePresentation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BuildFailureReason -> BuildFailurePresentation
ShowBuildSummaryOnly   BuildFailureReason
reason)
            (BuildFailureReason -> String -> BuildFailurePresentation
ShowBuildSummaryAndLog BuildFailureReason
reason) (Maybe String -> BuildFailurePresentation)
-> Maybe String -> BuildFailurePresentation
forall a b. (a -> b) -> a -> b
$ do
        String
logfile <- Maybe String
mlogfile
        SomeException
e       <- BuildFailureReason -> Maybe SomeException
buildFailureException BuildFailureReason
reason
        ExitFailure Int
1 <- SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
        String -> Maybe String
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
      , ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
pkgid
      , BuildFailureReason -> Bool
isFailureSelfExplanatory (BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
failure)
      , CurrentCommand
currentCommand CurrentCommand -> CurrentCommand -> Bool
forall a. Eq a => a -> a -> Bool
/= CurrentCommand
InstallCommand
      = 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) <- SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = Bool
True

    isFailureSelfExplanatory (ConfigureFailed SomeException
e)
      | Just (ExitFailure Int
1) <- SomeException -> Maybe ExitCode
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 <- ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
plan
      , ElaboratedConfiguredPackage -> Bool
forall pkg. HasUnitId pkg => pkg -> Bool
hasNoDependents ElaboratedConfiguredPackage
pkg ]

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

    hasNoDependents :: HasUnitId pkg => pkg -> Bool
    hasNoDependents :: pkg -> Bool
hasNoDependents = [GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([GenericPlanPackage
    InstalledPackageInfo ElaboratedConfiguredPackage]
 -> Bool)
-> (pkg
    -> [GenericPlanPackage
          InstalledPackageInfo ElaboratedConfiguredPackage])
-> pkg
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ElaboratedInstallPlan
-> UnitId
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> UnitId -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.revDirectDeps ElaboratedInstallPlan
plan (UnitId
 -> [GenericPlanPackage
       InstalledPackageInfo ElaboratedConfiguredPackage])
-> (pkg -> UnitId)
-> pkg
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. pkg -> UnitId
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ BuildFailureReason -> String
renderFailureExtraDetail BuildFailureReason
reason
     String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
-> (SomeException -> String) -> Maybe SomeException -> String
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          UnpackFailed    SomeException
_ -> String
"Failed to unpack "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          ConfigureFailed SomeException
_ -> String
"Failed to build "    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          BuildFailed     SomeException
_ -> String
"Failed to build "    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          ReplFailed      SomeException
_ -> String
"repl failed for "    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          HaddocksFailed  SomeException
_ -> String
"Failed to build documentation for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          TestsFailed     SomeException
_ -> String
"Tests failed for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          BenchFailed     SomeException
_ -> String
"Benchmarks failed for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          InstallFailed   SomeException
_ -> String
"Failed to build "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
pkgstr
          DependentFailed PackageId
depid
                            -> String
"Failed to build " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow (ElaboratedConfiguredPackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId ElaboratedConfiguredPackage
pkg)
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" because it depends on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
depid
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" which itself failed to build"
      where
        pkgstr :: String
pkgstr = Verbosity -> ElaboratedConfiguredPackage -> String
elabConfiguredName Verbosity
verbosity ElaboratedConfiguredPackage
pkg
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ if Bool
mentionDepOf
                   then UnitId -> String
renderDependencyOf (ElaboratedConfiguredPackage -> UnitId
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 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1:GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2:[]) ->
          String
" (which is required by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
        (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1:GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2:[GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage]
_)  ->
          String
" (which is required by " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p1
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Verbosity
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> String
elabPlanPackageName Verbosity
verbosity GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
p2
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" and others)"

    showException :: SomeException -> String
showException SomeException
e = case SomeException -> Maybe ExitCode
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
sigSEGV ->
            String
" The build process segfaulted (i.e. SIGSEGV)."

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

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

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

      Maybe ExitCode
_ -> String
" The exception was:\n  "
#if MIN_VERSION_base(4,8,0)
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
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 -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        UnpackFailed    SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        ConfigureFailed SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        BuildFailed     SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        ReplFailed      SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        HaddocksFailed  SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        TestsFailed     SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        BenchFailed     SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        InstallFailed   SomeException
e -> SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e
        DependentFailed PackageId
_ -> Maybe SomeException
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
    String
cabalDir <- IO String
getCabalDir

    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 = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigLogsDir
        mstoreDir :: Maybe String
mstoreDir = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigStoreDir
        cabalDirLayout :: CabalDirLayout
cabalDirLayout = String -> Maybe String -> Maybe String -> CabalDirLayout
mkCabalDirLayout String
cabalDir Maybe String
mstoreDir Maybe String
mlogsDir

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

    ProjectBaseContext -> IO ProjectBaseContext
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext :: DistDirLayout
-> CabalDirLayout
-> ProjectConfig
-> [PackageSpecifier UnresolvedSourcePackage]
-> BuildTimeSettings
-> CurrentCommand
-> ProjectBaseContext
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
    }

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 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DistDirLayout -> String
distDirectory DistDirLayout
distDirLayout
    Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ DistDirLayout -> String
distProjectCacheDirectory DistDirLayout
distDirLayout

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