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

-- | 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
  , resolveTargetsFromSolver
  , resolveTargetsFromLocalPackages
  , 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 Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
  ( makeAbsolute
  )
import Prelude ()

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

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

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

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

import Distribution.PackageDescription.Configuration
import Distribution.Solver.Types.OptionalStanza
import Distribution.Types.Component

import Control.Exception (assert)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Client.Errors
import Distribution.Package
import Distribution.Simple.Command (commandShowOptions)
import Distribution.Simple.Compiler
  ( OptimisationLevel (..)
  , compilerCompatVersion
  , compilerId
  , compilerInfo
  , showCompilerId
  )
import Distribution.Simple.Configure (computeEffectiveProfiling)
import Distribution.Simple.Flag
  ( flagToMaybe
  , fromFlagOrDefault
  )
import Distribution.Simple.LocalBuildInfo
  ( ComponentName (..)
  , pkgComponents
  )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.Setup as Setup
import Distribution.Simple.Utils
  ( createDirectoryIfMissingVerbose
  , debugNoWrap
  , dieWithException
  , notice
  , noticeNoWrap
  , ordNub
  , warn
  )
import Distribution.System
  ( Platform (Platform)
  )
import Distribution.Types.Flag
  ( FlagAssignment
  , diffFlagAssignment
  , showFlagAssignment
  )
import Distribution.Utils.NubList
  ( fromNubList
  )
import Distribution.Utils.Path (makeSymbolicPath)
import Distribution.Verbosity
import Distribution.Version
  ( mkVersion
  )
#ifdef MIN_VERSION_unix
import           System.Posix.Signals (sigKILL, sigSEGV)

#endif

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

-- | This holds the context of a project prior to solving: the content of the
-- @cabal.project@, @cabal/config@ 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]
  -- ^ Note: these are all the packages mentioned in the project configuration.
  -- Whether or not they will be considered local to the project will be decided
  -- by `shouldBeLocal` in ProjectPlanning.
  , ProjectBaseContext -> BuildTimeSettings
buildSettings :: BuildTimeSettings
  , ProjectBaseContext -> CurrentCommand
currentCommand :: CurrentCommand
  , ProjectBaseContext -> Maybe InstalledPackageIndex
installedPackages :: Maybe InstalledPackageIndex
  }

establishProjectBaseContext
  :: Verbosity
  -> ProjectConfig
  -> CurrentCommand
  -> IO ProjectBaseContext
establishProjectBaseContext :: Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
verbosity ProjectConfig
cliConfig CurrentCommand
currentCommand = do
  ProjectRoot
projectRoot <- (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 a. a -> IO a
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
=<< Verbosity
-> Maybe String
-> Maybe String
-> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot Verbosity
verbosity Maybe String
mprojectDir Maybe String
mprojectFile
  Verbosity
-> ProjectConfig
-> ProjectRoot
-> CurrentCommand
-> IO ProjectBaseContext
establishProjectBaseContextWithRoot Verbosity
verbosity ProjectConfig
cliConfig ProjectRoot
projectRoot CurrentCommand
currentCommand
  where
    mprojectDir :: Maybe String
mprojectDir = Flag String -> Maybe String
forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigProjectDir
    mprojectFile :: Maybe String
mprojectFile = Flag String -> Maybe String
forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigProjectFile
    ProjectConfigShared{Flag String
projectConfigProjectDir :: Flag String
projectConfigProjectDir :: ProjectConfigShared -> Flag String
projectConfigProjectDir, Flag String
projectConfigProjectFile :: Flag String
projectConfigProjectFile :: ProjectConfigShared -> Flag String
projectConfigProjectFile} = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig

-- | Like 'establishProjectBaseContext' but doesn't search for project root.
establishProjectBaseContextWithRoot
  :: Verbosity
  -> ProjectConfig
  -> ProjectRoot
  -> CurrentCommand
  -> IO ProjectBaseContext
establishProjectBaseContextWithRoot :: Verbosity
-> ProjectConfig
-> ProjectRoot
-> CurrentCommand
-> IO ProjectBaseContext
establishProjectBaseContextWithRoot Verbosity
verbosity ProjectConfig
cliConfig ProjectRoot
projectRoot CurrentCommand
currentCommand = do
  let haddockOutputDir :: Maybe String
haddockOutputDir = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (PackageConfig -> Flag String
packageConfigHaddockOutputDir (ProjectConfig -> PackageConfig
projectConfigLocalPackages ProjectConfig
cliConfig))
  let distDirLayout :: DistDirLayout
distDirLayout = ProjectRoot -> Maybe String -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory Maybe String
haddockOutputDir

  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 :: 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
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)
forall (f :: * -> *) a. Applicative f => Maybe (f a) -> f (Maybe 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

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

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

  -- https://github.com/haskell/cabal/issues/6013
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ProjectConfig -> [String]
projectPackages ProjectConfig
projectConfig) Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    ProjectBaseContext
      { DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout
      , CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout
      , ProjectConfig
projectConfig :: ProjectConfig
projectConfig :: ProjectConfig
projectConfig
      , [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages
      , BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings
      , CurrentCommand
currentCommand :: CurrentCommand
currentCommand :: CurrentCommand
currentCommand
      , Maybe InstalledPackageIndex
forall {a}. Maybe a
installedPackages :: Maybe InstalledPackageIndex
installedPackages :: forall {a}. Maybe a
installedPackages
      }
  where
    mdistDirectory :: Maybe String
mdistDirectory = Flag String -> Maybe String
forall a. Flag a -> Maybe a
Setup.flagToMaybe Flag String
projectConfigDistDir
    ProjectConfigShared{Flag String
projectConfigDistDir :: Flag String
projectConfigDistDir :: ProjectConfigShared -> Flag String
projectConfigDistDir} = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig
    installedPackages :: Maybe a
installedPackages = Maybe a
forall {a}. Maybe a
Nothing

-- | This holds the context between the pre-build, build and post-build phases.
data ProjectBuildContext = ProjectBuildContext
  { ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanOriginal :: ElaboratedInstallPlan
  -- ^ 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
elaboratedPlanToExecute :: 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 -> ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
  -- ^ 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 -> BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
  -- ^ The result of the dry-run phase. This tells us about each member of
  -- the 'elaboratedPlanToExecute'.
  , ProjectBuildContext -> TargetsMap
targetsMap :: TargetsMap
  -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in
  -- CmdRun, where we need a valid target to execute.
  }

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

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

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

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

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

    -- Improve the plan by marking up-to-date packages as installed.
    --
    let elaboratedPlan'' :: ElaboratedInstallPlan
elaboratedPlan'' =
          BuildStatusMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages
            BuildStatusMap
pkgsBuildStatus
            ElaboratedInstallPlan
elaboratedPlan'
    Verbosity -> String -> IO ()
debugNoWrap Verbosity
verbosity (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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
      ProjectBuildContext
        { elaboratedPlanOriginal :: ElaboratedInstallPlan
elaboratedPlanOriginal = ElaboratedInstallPlan
elaboratedPlan
        , elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedPlanToExecute = ElaboratedInstallPlan
elaboratedPlan''
        , ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared
        , BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus
        , targetsMap :: TargetsMap
targetsMap = TargetsMap
targets
        }

-- | Build phase: now do it.
--
-- Execute all or parts of the description of what to do to build or
-- rebuild the various packages needed.
runProjectBuildPhase
  :: Verbosity
  -> ProjectBaseContext
  -> ProjectBuildContext
  -> IO BuildOutcomes
runProjectBuildPhase :: Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
_ ProjectBaseContext{BuildTimeSettings
buildSettings :: ProjectBaseContext -> BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings} ProjectBuildContext
_
  | BuildTimeSettings -> Bool
buildSettingDryRun BuildTimeSettings
buildSettings =
      BuildOutcomes -> IO BuildOutcomes
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BuildOutcomes
forall k a. Map k a
Map.empty
runProjectBuildPhase
  Verbosity
verbosity
  ProjectBaseContext{[PackageSpecifier UnresolvedSourcePackage]
Maybe InstalledPackageIndex
BuildTimeSettings
ProjectConfig
CabalDirLayout
DistDirLayout
CurrentCommand
distDirLayout :: ProjectBaseContext -> DistDirLayout
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
projectConfig :: ProjectBaseContext -> ProjectConfig
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
buildSettings :: ProjectBaseContext -> BuildTimeSettings
currentCommand :: ProjectBaseContext -> CurrentCommand
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
distDirLayout :: DistDirLayout
cabalDirLayout :: CabalDirLayout
projectConfig :: ProjectConfig
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
buildSettings :: BuildTimeSettings
currentCommand :: CurrentCommand
installedPackages :: Maybe InstalledPackageIndex
..}
  ProjectBuildContext{TargetsMap
BuildStatusMap
ElaboratedInstallPlan
ElaboratedSharedConfig
elaboratedPlanOriginal :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
targetsMap :: ProjectBuildContext -> TargetsMap
elaboratedPlanOriginal :: ElaboratedInstallPlan
elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedShared :: ElaboratedSharedConfig
pkgsBuildStatus :: BuildStatusMap
targetsMap :: TargetsMap
..} =
    (BuildOutcomes -> BuildOutcomes)
-> IO BuildOutcomes -> IO BuildOutcomes
forall a b. (a -> b) -> IO a -> IO b
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
-> ProjectConfig
-> DistDirLayout
-> StoreDirLayout
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
-> BuildTimeSettings
-> IO BuildOutcomes
rebuildTargets
        Verbosity
verbosity
        ProjectConfig
projectConfig
        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 BuildOutcome)
-> BuildStatusMap -> BuildOutcomes
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((BuildStatus -> Maybe BuildOutcome)
 -> BuildStatusMap -> BuildOutcomes)
-> (BuildStatus -> Maybe BuildOutcome)
-> BuildStatusMap
-> BuildOutcomes
forall a b. (a -> b) -> a -> b
$ \BuildStatus
status -> case BuildStatus
status of
          BuildStatusUpToDate BuildResult
buildSuccess -> BuildOutcome -> Maybe BuildOutcome
forall a. a -> Maybe a
Just (BuildResult -> BuildOutcome
forall a b. b -> Either a b
Right BuildResult
buildSuccess)
          -- TODO: [nice to have] record build failures persistently
          BuildStatus
_ -> Maybe BuildOutcome
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 :: ProjectBaseContext -> BuildTimeSettings
buildSettings :: BuildTimeSettings
buildSettings} ProjectBuildContext
_ BuildOutcomes
_
  | BuildTimeSettings -> Bool
buildSettingDryRun BuildTimeSettings
buildSettings =
      () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runProjectPostBuildPhase
  Verbosity
verbosity
  ProjectBaseContext{[PackageSpecifier UnresolvedSourcePackage]
Maybe InstalledPackageIndex
BuildTimeSettings
ProjectConfig
CabalDirLayout
DistDirLayout
CurrentCommand
distDirLayout :: ProjectBaseContext -> DistDirLayout
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
projectConfig :: ProjectBaseContext -> ProjectConfig
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
buildSettings :: ProjectBaseContext -> BuildTimeSettings
currentCommand :: ProjectBaseContext -> CurrentCommand
installedPackages :: ProjectBaseContext -> Maybe InstalledPackageIndex
distDirLayout :: DistDirLayout
cabalDirLayout :: CabalDirLayout
projectConfig :: ProjectConfig
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
buildSettings :: BuildTimeSettings
currentCommand :: CurrentCommand
installedPackages :: Maybe InstalledPackageIndex
..}
  bc :: ProjectBuildContext
bc@ProjectBuildContext{TargetsMap
BuildStatusMap
ElaboratedInstallPlan
ElaboratedSharedConfig
elaboratedPlanOriginal :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
targetsMap :: ProjectBuildContext -> TargetsMap
elaboratedPlanOriginal :: ElaboratedInstallPlan
elaboratedPlanToExecute :: ElaboratedInstallPlan
elaboratedShared :: ElaboratedSharedConfig
pkgsBuildStatus :: BuildStatusMap
targetsMap :: TargetsMap
..}
  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 = TargetsMapX UnitId

type TargetsMapX u = Map u [(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

-- | Resolve targets from a solver result.
--
-- This is a convenience wrapper around 'resolveTargetsFromSolver' that takes an
-- 'ElaboratedInstallPlan' directly, rather than requiring the caller to
-- construct the 'AvailableTargetIndexes' first.
resolveTargetsFromSolver
  :: 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
resolveTargetsFromSolver :: 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
resolveTargetsFromSolver forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget ElaboratedInstallPlan
installPlan Maybe SourcePackageDb
sourceDb [TargetSelector]
targetSelectors =
  (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> AvailableTargetIndexes UnitId
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
forall u err.
Ord u =>
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> AvailableTargetIndexes u
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] (TargetsMapX u)
resolveTargets
    TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets
    SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget
    (ElaboratedInstallPlan -> AvailableTargetIndexes UnitId
availableTargetIndexes ElaboratedInstallPlan
installPlan)
    Maybe SourcePackageDb
sourceDb
    [TargetSelector]
targetSelectors

-- | Resolve targets from local packages.
--
-- This is a convenience wrapper around 'resolveTargets' that takes a list of
-- 'PackageSpecifier's directly, rather than requiring the caller to
-- construct the 'AvailableTargetIndexes' first.
resolveTargetsFromLocalPackages
  :: forall err
   . ( forall k
        . TargetSelector
       -> [AvailableTarget k]
       -> Either (TargetProblem err) [k]
     )
  -> ( forall k
        . SubComponentTarget
       -> AvailableTarget k
       -> Either (TargetProblem err) k
     )
  -> [PackageSpecifier UnresolvedSourcePackage]
  -> [TargetSelector]
  -> Either [TargetProblem err] (TargetsMapX PackageId)
resolveTargetsFromLocalPackages :: forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [TargetSelector]
-> Either [TargetProblem err] (TargetsMapX PackageIdentifier)
resolveTargetsFromLocalPackages forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers [TargetSelector]
targetSelectors =
  (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> AvailableTargetIndexes PackageIdentifier
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] (TargetsMapX PackageIdentifier)
forall u err.
Ord u =>
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> AvailableTargetIndexes u
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] (TargetsMapX u)
resolveTargets
    TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets
    SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget
    ([PackageSpecifier UnresolvedSourcePackage]
-> AvailableTargetIndexes PackageIdentifier
availableTargetIndexesFromSourcePackages [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers)
    Maybe SourcePackageDb
forall {a}. Maybe a
Nothing
    [TargetSelector]
targetSelectors

-- | 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 u err
   . Ord u
  => ( forall k
        . TargetSelector
       -> [AvailableTarget k]
       -> Either (TargetProblem err) [k]
     )
  -> ( forall k
        . SubComponentTarget
       -> AvailableTarget k
       -> Either (TargetProblem err) k
     )
  -> AvailableTargetIndexes u
  -> Maybe (SourcePackageDb)
  -> [TargetSelector]
  -> Either [TargetProblem err] (TargetsMapX u)
resolveTargets :: forall u err.
Ord u =>
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> AvailableTargetIndexes u
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] (TargetsMapX u)
resolveTargets
  forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets
  forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k
selectComponentTarget
  AvailableTargetIndexes{AvailableTargetsMap (PackageName, ComponentName) u
AvailableTargetsMap (PackageName, UnqualComponentName) u
AvailableTargetsMap (PackageIdentifier, ComponentName) u
AvailableTargetsMap PackageName u
AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName) u
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageName :: AvailableTargetsMap PackageName u
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName) u
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName) u
availableTargetsByPackageNameAndUnqualComponentName :: forall u.
AvailableTargetIndexes u
-> AvailableTargetsMap (PackageName, UnqualComponentName) u
availableTargetsByPackageNameAndComponentName :: forall u.
AvailableTargetIndexes u
-> AvailableTargetsMap (PackageName, ComponentName) u
availableTargetsByPackageName :: forall u.
AvailableTargetIndexes u -> AvailableTargetsMap PackageName u
availableTargetsByPackageId :: forall u.
AvailableTargetIndexes u -> AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageIdAndComponentName :: forall u.
AvailableTargetIndexes u
-> AvailableTargetsMap (PackageIdentifier, ComponentName) u
..}
  Maybe SourcePackageDb
mPkgDb =
    ([(TargetSelector, [(u, ComponentTarget)])] -> TargetsMapX u)
-> Either
     [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
-> Either [TargetProblem err] (TargetsMapX u)
forall a b.
(a -> b)
-> Either [TargetProblem err] a -> Either [TargetProblem err] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(TargetSelector, [(u, ComponentTarget)])] -> TargetsMapX u
mkTargetsMap
      (Either
   [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
 -> Either [TargetProblem err] (TargetsMapX u))
-> ([TargetSelector]
    -> Either
         [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])])
-> [TargetSelector]
-> Either [TargetProblem err] (TargetsMapX u)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (TargetProblem err)
 -> Either
      [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])])
-> ([(TargetSelector, [(u, ComponentTarget)])]
    -> Either
         [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])])
-> Either
     (NonEmpty (TargetProblem err))
     [(TargetSelector, [(u, ComponentTarget)])]
-> Either
     [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([TargetProblem err]
-> Either
     [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
forall a b. a -> Either a b
Left ([TargetProblem err]
 -> Either
      [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])])
-> (NonEmpty (TargetProblem err) -> [TargetProblem err])
-> NonEmpty (TargetProblem err)
-> Either
     [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (TargetProblem err) -> [TargetProblem err]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList) [(TargetSelector, [(u, ComponentTarget)])]
-> Either
     [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
forall a b. b -> Either a b
Right
      (Either
   (NonEmpty (TargetProblem err))
   [(TargetSelector, [(u, ComponentTarget)])]
 -> Either
      [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])])
-> ([TargetSelector]
    -> Either
         (NonEmpty (TargetProblem err))
         [(TargetSelector, [(u, ComponentTarget)])])
-> [TargetSelector]
-> Either
     [TargetProblem err] [(TargetSelector, [(u, ComponentTarget)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either
   (TargetProblem err) (TargetSelector, [(u, ComponentTarget)])]
-> Either
     (NonEmpty (TargetProblem err))
     [(TargetSelector, [(u, ComponentTarget)])]
forall e a. [Either e a] -> Either (NonEmpty e) [a]
checkErrors
      ([Either
    (TargetProblem err) (TargetSelector, [(u, ComponentTarget)])]
 -> Either
      (NonEmpty (TargetProblem err))
      [(TargetSelector, [(u, ComponentTarget)])])
-> ([TargetSelector]
    -> [Either
          (TargetProblem err) (TargetSelector, [(u, ComponentTarget)])])
-> [TargetSelector]
-> Either
     (NonEmpty (TargetProblem err))
     [(TargetSelector, [(u, ComponentTarget)])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TargetSelector
 -> Either
      (TargetProblem err) (TargetSelector, [(u, ComponentTarget)]))
-> [TargetSelector]
-> [Either
      (TargetProblem err) (TargetSelector, [(u, ComponentTarget)])]
forall a b. (a -> b) -> [a] -> [b]
map (\TargetSelector
ts -> (,) TargetSelector
ts ([(u, ComponentTarget)]
 -> (TargetSelector, [(u, ComponentTarget)]))
-> Either (TargetProblem err) [(u, ComponentTarget)]
-> Either
     (TargetProblem err) (TargetSelector, [(u, ComponentTarget)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TargetSelector -> Either (TargetProblem err) [(u, ComponentTarget)]
checkTarget TargetSelector
ts)
    where
      mkTargetsMap
        :: [(TargetSelector, [(u, ComponentTarget)])]
        -> TargetsMapX u
      mkTargetsMap :: [(TargetSelector, [(u, ComponentTarget)])] -> TargetsMapX u
mkTargetsMap [(TargetSelector, [(u, ComponentTarget)])]
targets =
        ([(ComponentTarget, TargetSelector)]
 -> [(ComponentTarget, NonEmpty TargetSelector)])
-> Map u [(ComponentTarget, TargetSelector)] -> TargetsMapX u
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 u [(ComponentTarget, TargetSelector)] -> TargetsMapX u)
-> Map u [(ComponentTarget, TargetSelector)] -> TargetsMapX u
forall a b. (a -> b) -> a -> b
$
          ([(ComponentTarget, TargetSelector)]
 -> [(ComponentTarget, TargetSelector)]
 -> [(ComponentTarget, TargetSelector)])
-> [(u, [(ComponentTarget, TargetSelector)])]
-> Map u [(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
(<>)
            [ (u
uid, [(ComponentTarget
ct, TargetSelector
ts)])
            | (TargetSelector
ts, [(u, ComponentTarget)]
cts) <- [(TargetSelector, [(u, ComponentTarget)])]
targets
            , (u
uid, ComponentTarget
ct) <- [(u, ComponentTarget)]
cts
            ]

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

      -- We can ask to build any whole package, project-local or a dependency
      checkTarget :: TargetSelector -> Either (TargetProblem err) [(u, ComponentTarget)]
checkTarget bt :: TargetSelector
bt@(TargetPackage TargetImplicitCwd
_ ([PackageIdentifier] -> [PackageIdentifier]
forall a. Ord a => [a] -> [a]
ordNub -> [PackageIdentifier
pkgid]) Maybe ComponentKindFilter
mkfilter)
        | Just [AvailableTarget (u, ComponentName)]
ats <-
            ([AvailableTarget (u, ComponentName)]
 -> [AvailableTarget (u, ComponentName)])
-> Maybe [AvailableTarget (u, ComponentName)]
-> Maybe [AvailableTarget (u, ComponentName)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([AvailableTarget (u, ComponentName)]
 -> [AvailableTarget (u, ComponentName)])
-> (ComponentKindFilter
    -> [AvailableTarget (u, ComponentName)]
    -> [AvailableTarget (u, ComponentName)])
-> Maybe ComponentKindFilter
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall a. a -> a
id ComponentKindFilter
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter) (Maybe [AvailableTarget (u, ComponentName)]
 -> Maybe [AvailableTarget (u, ComponentName)])
-> Maybe [AvailableTarget (u, ComponentName)]
-> Maybe [AvailableTarget (u, ComponentName)]
forall a b. (a -> b) -> a -> b
$
              PackageIdentifier
-> AvailableTargetsMap PackageIdentifier u
-> Maybe [AvailableTarget (u, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageIdentifier
pkgid AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageId =
            ([(u, ComponentName)] -> [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b.
(a -> b)
-> Either (TargetProblem err) a -> Either (TargetProblem err) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(u, ComponentName)] -> [(u, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent) (Either (TargetProblem err) [(u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$
              TargetSelector
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentName)]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt [AvailableTarget (u, ComponentName)]
ats
        | Bool
otherwise =
            TargetProblem err
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageIdentifier -> TargetProblem err
forall a. PackageIdentifier -> TargetProblem a
TargetProblemNoSuchPackage PackageIdentifier
pkgid)
      checkTarget (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
pkgids Maybe ComponentKindFilter
_) =
        String -> Either (TargetProblem err) [(u, 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 ((PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow [PackageIdentifier]
pkgids)
          )
      -- For the moment this error cannot happen here, because it gets
      -- detected when the package config is being constructed. This case
      -- will need handling properly when we do add support.
      --
      -- TODO: how should this use case play together with the
      -- '--cabal-file' option of 'configure' which allows using multiple
      -- .cabal files for a single package?

      checkTarget bt :: TargetSelector
bt@(TargetAllPackages Maybe ComponentKindFilter
mkfilter) =
        ([(u, ComponentName)] -> [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b.
(a -> b)
-> Either (TargetProblem err) a -> Either (TargetProblem err) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(u, ComponentName)] -> [(u, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
          (Either (TargetProblem err) [(u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> ([AvailableTarget (u, ComponentName)]
    -> Either (TargetProblem err) [(u, ComponentName)])
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSelector
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentName)]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt
          ([AvailableTarget (u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentName)])
-> ([AvailableTarget (u, ComponentName)]
    -> [AvailableTarget (u, ComponentName)])
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([AvailableTarget (u, ComponentName)]
 -> [AvailableTarget (u, ComponentName)])
-> (ComponentKindFilter
    -> [AvailableTarget (u, ComponentName)]
    -> [AvailableTarget (u, ComponentName)])
-> Maybe ComponentKindFilter
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall a. a -> a
id ComponentKindFilter
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter
          ([AvailableTarget (u, ComponentName)]
 -> [AvailableTarget (u, ComponentName)])
-> ([AvailableTarget (u, ComponentName)]
    -> [AvailableTarget (u, ComponentName)])
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AvailableTarget (u, ComponentName) -> Bool)
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall a. (a -> Bool) -> [a] -> [a]
filter AvailableTarget (u, ComponentName) -> Bool
forall k. AvailableTarget k -> Bool
availableTargetLocalToProject
          ([AvailableTarget (u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$ [[AvailableTarget (u, ComponentName)]]
-> [AvailableTarget (u, ComponentName)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (AvailableTargetsMap PackageIdentifier u
-> [[AvailableTarget (u, ComponentName)]]
forall k a. Map k a -> [a]
Map.elems AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageId)
      checkTarget (TargetComponent PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)
        | Just [AvailableTarget (u, ComponentName)]
ats <-
            (PackageIdentifier, ComponentName)
-> AvailableTargetsMap (PackageIdentifier, ComponentName) u
-> Maybe [AvailableTarget (u, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
              (PackageIdentifier
pkgid, ComponentName
cname)
              AvailableTargetsMap (PackageIdentifier, ComponentName) u
availableTargetsByPackageIdAndComponentName =
            ([(u, ComponentName)] -> [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b.
(a -> b)
-> Either (TargetProblem err) a -> Either (TargetProblem err) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(u, ComponentName)] -> [(u, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget) (Either (TargetProblem err) [(u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$
              SubComponentTarget
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentName)]
forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget [AvailableTarget (u, ComponentName)]
ats
        | PackageIdentifier
-> AvailableTargetsMap PackageIdentifier u -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageIdentifier
pkgid AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageId =
            TargetProblem err
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageIdentifier -> ComponentName -> TargetProblem err
forall a. PackageIdentifier -> ComponentName -> TargetProblem a
TargetProblemNoSuchComponent PackageIdentifier
pkgid ComponentName
cname)
        | Bool
otherwise =
            TargetProblem err
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. a -> Either a b
Left (PackageIdentifier -> TargetProblem err
forall a. PackageIdentifier -> TargetProblem a
TargetProblemNoSuchPackage PackageIdentifier
pkgid)
      checkTarget (TargetComponentUnknown PackageName
pkgname Either UnqualComponentName ComponentName
ecname SubComponentTarget
subtarget)
        | Just [AvailableTarget (u, ComponentName)]
ats <- case Either UnqualComponentName ComponentName
ecname of
            Left UnqualComponentName
ucname ->
              (PackageName, UnqualComponentName)
-> AvailableTargetsMap (PackageName, UnqualComponentName) u
-> Maybe [AvailableTarget (u, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
                (PackageName
pkgname, UnqualComponentName
ucname)
                AvailableTargetsMap (PackageName, UnqualComponentName) u
availableTargetsByPackageNameAndUnqualComponentName
            Right ComponentName
cname ->
              (PackageName, ComponentName)
-> AvailableTargetsMap (PackageName, ComponentName) u
-> Maybe [AvailableTarget (u, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
                (PackageName
pkgname, ComponentName
cname)
                AvailableTargetsMap (PackageName, ComponentName) u
availableTargetsByPackageNameAndComponentName =
            ([(u, ComponentName)] -> [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b.
(a -> b)
-> Either (TargetProblem err) a -> Either (TargetProblem err) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(u, ComponentName)] -> [(u, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
subtarget) (Either (TargetProblem err) [(u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$
              SubComponentTarget
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentName)]
forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget [AvailableTarget (u, ComponentName)]
ats
        | PackageName -> AvailableTargetsMap PackageName u -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member PackageName
pkgname AvailableTargetsMap PackageName u
availableTargetsByPackageName =
            TargetProblem err
-> Either (TargetProblem err) [(u, 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) [(u, 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 (u, ComponentName)]
ats <-
            ([AvailableTarget (u, ComponentName)]
 -> [AvailableTarget (u, ComponentName)])
-> Maybe [AvailableTarget (u, ComponentName)]
-> Maybe [AvailableTarget (u, ComponentName)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([AvailableTarget (u, ComponentName)]
 -> [AvailableTarget (u, ComponentName)])
-> (ComponentKindFilter
    -> [AvailableTarget (u, ComponentName)]
    -> [AvailableTarget (u, ComponentName)])
-> Maybe ComponentKindFilter
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall a. a -> a
id ComponentKindFilter
-> [AvailableTarget (u, ComponentName)]
-> [AvailableTarget (u, ComponentName)]
forall k.
ComponentKindFilter -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind Maybe ComponentKindFilter
mkfilter) (Maybe [AvailableTarget (u, ComponentName)]
 -> Maybe [AvailableTarget (u, ComponentName)])
-> Maybe [AvailableTarget (u, ComponentName)]
-> Maybe [AvailableTarget (u, ComponentName)]
forall a b. (a -> b) -> a -> b
$
              PackageName
-> AvailableTargetsMap PackageName u
-> Maybe [AvailableTarget (u, ComponentName)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkgname AvailableTargetsMap PackageName u
availableTargetsByPackageName =
            ([(u, ComponentName)] -> [(u, ComponentTarget)])
-> Either (TargetProblem err) [(u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b.
(a -> b)
-> Either (TargetProblem err) a -> Either (TargetProblem err) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SubComponentTarget
-> [(u, ComponentName)] -> [(u, ComponentTarget)]
forall b.
SubComponentTarget
-> [(b, ComponentName)] -> [(b, ComponentTarget)]
componentTargets SubComponentTarget
WholeComponent)
              (Either (TargetProblem err) [(u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> ([AvailableTarget (u, ComponentName)]
    -> Either (TargetProblem err) [(u, ComponentName)])
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSelector
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentName)]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectPackageTargets TargetSelector
bt
              ([AvailableTarget (u, ComponentName)]
 -> Either (TargetProblem err) [(u, ComponentTarget)])
-> [AvailableTarget (u, ComponentName)]
-> Either (TargetProblem err) [(u, ComponentTarget)]
forall a b. (a -> b) -> a -> b
$ [AvailableTarget (u, ComponentName)]
ats
        | Just SourcePackageDb{PackageIndex UnresolvedSourcePackage
packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex :: SourcePackageDb -> 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnresolvedSourcePackage]
pkg) =
            TargetProblem err
-> Either (TargetProblem err) [(u, 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) [(u, 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 :: forall b.
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 a b. (a -> b) -> (b, a) -> (b, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ComponentName
cname -> ComponentName -> SubComponentTarget -> ComponentTarget
ComponentTarget ComponentName
cname SubComponentTarget
subtarget))

      selectComponentTargets
        :: SubComponentTarget
        -> [AvailableTarget k]
        -> Either (TargetProblem err) [k]
      selectComponentTargets :: forall k.
SubComponentTarget
-> [AvailableTarget k] -> Either (TargetProblem err) [k]
selectComponentTargets SubComponentTarget
subtarget =
        (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 :: forall e a. [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
e e -> [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 u = AvailableTargetIndexes
  { forall u.
AvailableTargetIndexes u
-> AvailableTargetsMap (PackageIdentifier, ComponentName) u
availableTargetsByPackageIdAndComponentName
      :: AvailableTargetsMap (PackageId, ComponentName) u
  , forall u.
AvailableTargetIndexes u -> AvailableTargetsMap PackageIdentifier u
availableTargetsByPackageId
      :: AvailableTargetsMap PackageId u
  , forall u.
AvailableTargetIndexes u -> AvailableTargetsMap PackageName u
availableTargetsByPackageName
      :: AvailableTargetsMap PackageName u
  , forall u.
AvailableTargetIndexes u
-> AvailableTargetsMap (PackageName, ComponentName) u
availableTargetsByPackageNameAndComponentName
      :: AvailableTargetsMap (PackageName, ComponentName) u
  , forall u.
AvailableTargetIndexes u
-> AvailableTargetsMap (PackageName, UnqualComponentName) u
availableTargetsByPackageNameAndUnqualComponentName
      :: AvailableTargetsMap (PackageName, UnqualComponentName) u
  }
type AvailableTargetsMap k u = Map k [AvailableTarget (u, 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 UnitId
availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes UnitId
availableTargetIndexes ElaboratedInstallPlan
installPlan = AvailableTargetIndexes{AvailableTargetsMap (PackageName, ComponentName) UnitId
AvailableTargetsMap (PackageName, UnqualComponentName) UnitId
AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
AvailableTargetsMap PackageName UnitId
AvailableTargetsMap PackageIdentifier UnitId
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName) UnitId
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName) UnitId
availableTargetsByPackageName :: AvailableTargetsMap PackageName UnitId
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier UnitId
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier UnitId
availableTargetsByPackageName :: AvailableTargetsMap PackageName UnitId
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName) UnitId
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName) UnitId
..}
  where
    availableTargetsByPackageIdAndComponentName
      :: Map
          (PackageId, ComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
availableTargetsByPackageIdAndComponentName =
      ElaboratedInstallPlan
-> AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
availableTargets ElaboratedInstallPlan
installPlan

    availableTargetsByPackageId
      :: Map PackageId [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier UnitId
availableTargetsByPackageId =
      ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> ((PackageIdentifier, ComponentName) -> PackageIdentifier)
-> AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
-> AvailableTargetsMap PackageIdentifier UnitId
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]
(++)
        (\(PackageIdentifier
pkgid, ComponentName
_cname) -> PackageIdentifier
pkgid)
        AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
availableTargetsByPackageIdAndComponentName
        AvailableTargetsMap PackageIdentifier UnitId
-> AvailableTargetsMap PackageIdentifier UnitId
-> AvailableTargetsMap PackageIdentifier UnitId
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` AvailableTargetsMap PackageIdentifier UnitId
forall {a}. Map PackageIdentifier [a]
availableTargetsEmptyPackages

    availableTargetsByPackageName
      :: Map PackageName [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageName :: AvailableTargetsMap PackageName UnitId
availableTargetsByPackageName =
      ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> (PackageIdentifier -> PackageName)
-> AvailableTargetsMap PackageIdentifier UnitId
-> AvailableTargetsMap PackageName UnitId
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]
(++)
        PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName
        AvailableTargetsMap PackageIdentifier UnitId
availableTargetsByPackageId

    availableTargetsByPackageNameAndComponentName
      :: Map
          (PackageName, ComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName) UnitId
availableTargetsByPackageNameAndComponentName =
      ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> ((PackageIdentifier, ComponentName)
    -> (PackageName, ComponentName))
-> AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
-> AvailableTargetsMap (PackageName, ComponentName) UnitId
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]
(++)
        (\(PackageIdentifier
pkgid, ComponentName
cname) -> (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid, ComponentName
cname))
        AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
availableTargetsByPackageIdAndComponentName

    availableTargetsByPackageNameAndUnqualComponentName
      :: Map
          (PackageName, UnqualComponentName)
          [AvailableTarget (UnitId, ComponentName)]
    availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap (PackageName, UnqualComponentName) UnitId
availableTargetsByPackageNameAndUnqualComponentName =
      ([AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)]
 -> [AvailableTarget (UnitId, ComponentName)])
-> ((PackageIdentifier, ComponentName)
    -> (PackageName, UnqualComponentName))
-> AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
-> AvailableTargetsMap (PackageName, UnqualComponentName) UnitId
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]
(++)
        ( \(PackageIdentifier
pkgid, ComponentName
cname) ->
            let pname :: PackageName
pname = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid
                cname' :: UnqualComponentName
cname' = PackageName -> ComponentName -> UnqualComponentName
unqualComponentName PackageName
pname ComponentName
cname
             in (PackageName
pname, UnqualComponentName
cname')
        )
        AvailableTargetsMap (PackageIdentifier, ComponentName) UnitId
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 PackageIdentifier [a]
availableTargetsEmptyPackages =
      [(PackageIdentifier, [a])] -> Map PackageIdentifier [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageDescription -> [Component]
pkgComponents (ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg))
        ]

-- | Create available target indexes from source packages.
--
-- This is useful when we need to resolve targets before solver resolution.
availableTargetIndexesFromSourcePackages
  :: [PackageSpecifier UnresolvedSourcePackage] -> AvailableTargetIndexes PackageId
availableTargetIndexesFromSourcePackages :: [PackageSpecifier UnresolvedSourcePackage]
-> AvailableTargetIndexes PackageIdentifier
availableTargetIndexesFromSourcePackages [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers = AvailableTargetIndexes{AvailableTargetsMap (PackageName, ComponentName) PackageIdentifier
AvailableTargetsMap
  (PackageName, UnqualComponentName) PackageIdentifier
AvailableTargetsMap
  (PackageIdentifier, ComponentName) PackageIdentifier
AvailableTargetsMap PackageName PackageIdentifier
AvailableTargetsMap PackageIdentifier PackageIdentifier
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap
  (PackageName, UnqualComponentName) PackageIdentifier
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName) PackageIdentifier
availableTargetsByPackageName :: AvailableTargetsMap PackageName PackageIdentifier
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier PackageIdentifier
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap
  (PackageIdentifier, ComponentName) PackageIdentifier
availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap
  (PackageIdentifier, ComponentName) PackageIdentifier
availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier PackageIdentifier
availableTargetsByPackageName :: AvailableTargetsMap PackageName PackageIdentifier
availableTargetsByPackageNameAndComponentName :: AvailableTargetsMap (PackageName, ComponentName) PackageIdentifier
availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap
  (PackageName, UnqualComponentName) PackageIdentifier
..}
  where
    -- Create a map of available targets from source packages
    availableTargetsByPackageIdAndComponentName
      :: Map (PackageId, ComponentName) [AvailableTarget (PackageId, ComponentName)]
    availableTargetsByPackageIdAndComponentName :: AvailableTargetsMap
  (PackageIdentifier, ComponentName) PackageIdentifier
availableTargetsByPackageIdAndComponentName =
      ([AvailableTarget (PackageIdentifier, ComponentName)]
 -> [AvailableTarget (PackageIdentifier, ComponentName)]
 -> [AvailableTarget (PackageIdentifier, ComponentName)])
-> [((PackageIdentifier, ComponentName),
     [AvailableTarget (PackageIdentifier, ComponentName)])]
-> AvailableTargetsMap
     (PackageIdentifier, ComponentName) PackageIdentifier
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [AvailableTarget (PackageIdentifier, ComponentName)]
-> [AvailableTarget (PackageIdentifier, ComponentName)]
-> [AvailableTarget (PackageIdentifier, ComponentName)]
forall a. [a] -> [a] -> [a]
(++) ([((PackageIdentifier, ComponentName),
   [AvailableTarget (PackageIdentifier, ComponentName)])]
 -> AvailableTargetsMap
      (PackageIdentifier, ComponentName) PackageIdentifier)
-> [((PackageIdentifier, ComponentName),
     [AvailableTarget (PackageIdentifier, ComponentName)])]
-> AvailableTargetsMap
     (PackageIdentifier, ComponentName) PackageIdentifier
forall a b. (a -> b) -> a -> b
$
        [[((PackageIdentifier, ComponentName),
   [AvailableTarget (PackageIdentifier, ComponentName)])]]
-> [((PackageIdentifier, ComponentName),
     [AvailableTarget (PackageIdentifier, ComponentName)])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
          [ [ ((PackageIdentifier
pkgId, ComponentName
cname), [PackageIdentifier
-> ComponentName
-> AvailableTarget (PackageIdentifier, ComponentName)
makeAvailableTarget PackageIdentifier
pkgId ComponentName
cname])
            | let pkgId :: PackageIdentifier
pkgId = UnresolvedSourcePackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId UnresolvedSourcePackage
pkg
            , ComponentName
cname <- (Component -> ComponentName) -> [Component] -> [ComponentName]
forall a b. (a -> b) -> [a] -> [b]
map Component -> ComponentName
componentName (PackageDescription -> [Component]
pkgComponents (PackageDescription -> [Component])
-> PackageDescription -> [Component]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription -> PackageDescription
flattenPackageDescription (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg))
            ]
          | SpecificSourcePackage UnresolvedSourcePackage
pkg <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
          ]

    -- Helper to create an available target
    makeAvailableTarget :: PackageIdentifier
-> ComponentName
-> AvailableTarget (PackageIdentifier, ComponentName)
makeAvailableTarget PackageIdentifier
pkgId ComponentName
cname =
      AvailableTarget
        { availableTargetPackageId :: PackageIdentifier
availableTargetPackageId = PackageIdentifier
pkgId
        , availableTargetComponentName :: ComponentName
availableTargetComponentName = ComponentName
cname
        , availableTargetStatus :: AvailableTargetStatus (PackageIdentifier, ComponentName)
availableTargetStatus = (PackageIdentifier, ComponentName)
-> TargetRequested
-> AvailableTargetStatus (PackageIdentifier, ComponentName)
forall k. k -> TargetRequested -> AvailableTargetStatus k
TargetBuildable (PackageIdentifier
pkgId, ComponentName
cname) TargetRequested
TargetRequestedByDefault
        , availableTargetLocalToProject :: Bool
availableTargetLocalToProject = Bool
True
        }

    -- Derive other indexes from the main one, just like in availableTargetIndexes
    availableTargetsByPackageId
      :: Map PackageId [AvailableTarget (PackageId, ComponentName)]
    availableTargetsByPackageId :: AvailableTargetsMap PackageIdentifier PackageIdentifier
availableTargetsByPackageId =
      ([AvailableTarget (PackageIdentifier, ComponentName)]
 -> [AvailableTarget (PackageIdentifier, ComponentName)]
 -> [AvailableTarget (PackageIdentifier, ComponentName)])
-> ((PackageIdentifier, ComponentName) -> PackageIdentifier)
-> AvailableTargetsMap
     (PackageIdentifier, ComponentName) PackageIdentifier
-> AvailableTargetsMap PackageIdentifier PackageIdentifier
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
        [AvailableTarget (PackageIdentifier, ComponentName)]
-> [AvailableTarget (PackageIdentifier, ComponentName)]
-> [AvailableTarget (PackageIdentifier, ComponentName)]
forall a. [a] -> [a] -> [a]
(++)
        (\(PackageIdentifier
pkgid, ComponentName
_cname) -> PackageIdentifier
pkgid)
        AvailableTargetsMap
  (PackageIdentifier, ComponentName) PackageIdentifier
availableTargetsByPackageIdAndComponentName
        AvailableTargetsMap PackageIdentifier PackageIdentifier
-> AvailableTargetsMap PackageIdentifier PackageIdentifier
-> AvailableTargetsMap PackageIdentifier PackageIdentifier
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` AvailableTargetsMap PackageIdentifier PackageIdentifier
forall {a}. Map PackageIdentifier [a]
availableTargetsEmptyPackages

    -- Handle empty packages
    availableTargetsEmptyPackages :: Map PackageIdentifier [a]
availableTargetsEmptyPackages =
      [(PackageIdentifier, [a])] -> Map PackageIdentifier [a]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (UnresolvedSourcePackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId UnresolvedSourcePackage
pkg, [])
        | SpecificSourcePackage UnresolvedSourcePackage
pkg <- [PackageSpecifier UnresolvedSourcePackage]
pkgSpecifiers
        , [Component] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageDescription -> [Component]
pkgComponents (GenericPackageDescription -> PackageDescription
flattenPackageDescription (UnresolvedSourcePackage -> GenericPackageDescription
forall loc. SourcePackage loc -> GenericPackageDescription
srcpkgDescription UnresolvedSourcePackage
pkg)))
        ]

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

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

    availableTargetsByPackageNameAndUnqualComponentName
      :: Map (PackageName, UnqualComponentName) [AvailableTarget (PackageId, ComponentName)]
    availableTargetsByPackageNameAndUnqualComponentName :: AvailableTargetsMap
  (PackageName, UnqualComponentName) PackageIdentifier
availableTargetsByPackageNameAndUnqualComponentName =
      ([AvailableTarget (PackageIdentifier, ComponentName)]
 -> [AvailableTarget (PackageIdentifier, ComponentName)]
 -> [AvailableTarget (PackageIdentifier, ComponentName)])
-> ((PackageIdentifier, ComponentName)
    -> (PackageName, UnqualComponentName))
-> AvailableTargetsMap
     (PackageIdentifier, ComponentName) PackageIdentifier
-> AvailableTargetsMap
     (PackageName, UnqualComponentName) PackageIdentifier
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith
        [AvailableTarget (PackageIdentifier, ComponentName)]
-> [AvailableTarget (PackageIdentifier, ComponentName)]
-> [AvailableTarget (PackageIdentifier, ComponentName)]
forall a. [a] -> [a] -> [a]
(++)
        ( \(PackageIdentifier
pkgid, ComponentName
cname) ->
            let pname :: PackageName
pname = PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pkgid
                cname' :: UnqualComponentName
cname' = PackageName -> ComponentName -> UnqualComponentName
unqualComponentName PackageName
pname ComponentName
cname
             in (PackageName
pname, UnqualComponentName
cname')
        )
        AvailableTargetsMap
  (PackageIdentifier, ComponentName) PackageIdentifier
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

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

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

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

selectBuildableTargetsWith
  :: (TargetRequested -> Bool)
  -> [AvailableTarget k]
  -> [k]
selectBuildableTargetsWith :: forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith TargetRequested -> Bool
p = ((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' :: forall k. [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' :: forall k.
(TargetRequested -> Bool)
-> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith' TargetRequested -> Bool
p =
  (([AvailableTarget k] -> [AvailableTarget ()])
-> ([k], [AvailableTarget k]) -> ([k], [AvailableTarget ()])
forall a b. (a -> b) -> ([k], a) -> ([k], b)
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 :: forall k. AvailableTarget k -> AvailableTarget ()
forgetTargetDetail = (k -> ()) -> AvailableTarget k -> AvailableTarget ()
forall a b. (a -> b) -> AvailableTarget a -> AvailableTarget b
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 :: forall k. [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 :: forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic
  SubComponentTarget
subtarget
  AvailableTarget
    { availableTargetPackageId :: forall k. AvailableTarget k -> PackageIdentifier
availableTargetPackageId = PackageIdentifier
pkgid
    , availableTargetComponentName :: forall k. AvailableTarget k -> ComponentName
availableTargetComponentName = ComponentName
cname
    , AvailableTargetStatus k
availableTargetStatus :: forall k. AvailableTarget k -> AvailableTargetStatus k
availableTargetStatus :: AvailableTargetStatus k
availableTargetStatus
    } =
    case AvailableTargetStatus k
availableTargetStatus of
      AvailableTargetStatus k
TargetDisabledByUser ->
        TargetProblem a -> Either (TargetProblem a) k
forall a b. a -> Either a b
Left (PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetOptionalStanzaDisabledByUser PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)
      AvailableTargetStatus k
TargetDisabledBySolver ->
        TargetProblem a -> Either (TargetProblem a) k
forall a b. a -> Either a b
Left (PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetOptionalStanzaDisabledBySolver PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)
      AvailableTargetStatus k
TargetNotLocal ->
        TargetProblem a -> Either (TargetProblem a) k
forall a b. a -> Either a b
Left (PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetComponentNotProjectLocal PackageIdentifier
pkgid ComponentName
cname SubComponentTarget
subtarget)
      AvailableTargetStatus k
TargetNotBuildable ->
        TargetProblem a -> Either (TargetProblem a) k
forall a b. a -> Either a b
Left (PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
forall a.
PackageIdentifier
-> ComponentName -> SubComponentTarget -> TargetProblem a
TargetComponentNotBuildable PackageIdentifier
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 :: BuildTimeSettings -> Bool
buildSettingDryRun :: Bool
buildSettingDryRun, Bool
buildSettingKeepTempFiles :: Bool
buildSettingKeepTempFiles :: BuildTimeSettings -> Bool
buildSettingKeepTempFiles}
    , projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig =
      ProjectConfig
        { projectConfigAllPackages :: ProjectConfig -> PackageConfig
projectConfigAllPackages =
          PackageConfig{packageConfigOptimization :: PackageConfig -> Flag OptimisationLevel
packageConfigOptimization = Flag OptimisationLevel
globalOptimization}
        , projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages =
          PackageConfig{packageConfigOptimization :: PackageConfig -> Flag OptimisationLevel
packageConfigOptimization = Flag OptimisationLevel
localOptimization}
        }
    , CurrentCommand
currentCommand :: ProjectBaseContext -> CurrentCommand
currentCommand :: CurrentCommand
currentCommand
    }
  ProjectBuildContext
    { elaboratedPlanToExecute :: ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanToExecute = ElaboratedInstallPlan
elaboratedPlan
    , ElaboratedSharedConfig
elaboratedShared :: ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared :: ElaboratedSharedConfig
elaboratedShared
    , BuildStatusMap
pkgsBuildStatus :: ProjectBuildContext -> BuildStatusMap
pkgsBuildStatus :: BuildStatusMap
pkgsBuildStatus
    }
    | [GenericReadyPackage ElaboratedConfiguredPackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs Bool -> Bool -> Bool
&& CurrentCommand
currentCommand CurrentCommand -> CurrentCommand -> Bool
forall a. Eq a => a -> a -> Bool
== CurrentCommand
BuildCommand =
        Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"Up to date"
    | Bool -> Bool
not ([GenericReadyPackage ElaboratedConfiguredPackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenericReadyPackage ElaboratedConfiguredPackage]
pkgs) =
        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
    | Bool
otherwise = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    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 a. [a] -> 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 PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
elab)
            , case ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab of
                BuildInplaceOnly MemoryOrDisk
InMemory -> String
"(interactive)"
                BuildStyle
_ -> String
""
            , 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 a. [a] -> 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
", "
                [ PackageIdentifier -> ComponentTarget -> String
showComponentTarget (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
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 commonFlags :: CommonSetupFlags
commonFlags =
              Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Dist)
-> Bool
-> CommonSetupFlags
setupHsCommonFlags
                Verbosity
verbosity
                Maybe (SymbolicPath CWD ('Dir Pkg))
forall {a}. Maybe a
Nothing -- omit working directory
                (String -> SymbolicPath Pkg ('Dir Dist)
forall from (to :: FileOrDir). String -> SymbolicPath from to
makeSymbolicPath String
"$builddir")
                Bool
buildSettingKeepTempFiles
            fullConfigureFlags :: ConfigFlags
fullConfigureFlags =
              Identity ConfigFlags -> ConfigFlags
forall a. Identity a -> a
runIdentity (Identity ConfigFlags -> ConfigFlags)
-> Identity ConfigFlags -> ConfigFlags
forall a b. (a -> b) -> a -> b
$
                ( (String -> Identity (SymbolicPath Pkg ('Dir PkgDB)))
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> CommonSetupFlags
-> Identity ConfigFlags
forall (m :: * -> *).
Monad m =>
(String -> m (SymbolicPath Pkg ('Dir PkgDB)))
-> ElaboratedInstallPlan
-> GenericReadyPackage ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> CommonSetupFlags
-> m ConfigFlags
setupHsConfigureFlags
                    (\String
_ -> SymbolicPath Pkg ('Dir PkgDB)
-> Identity (SymbolicPath Pkg ('Dir PkgDB))
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> SymbolicPath Pkg ('Dir PkgDB)
forall a. HasCallStack => String -> a
error String
"unused"))
                    ElaboratedInstallPlan
elaboratedPlan
                    (ElaboratedConfiguredPackage
-> GenericReadyPackage ElaboratedConfiguredPackage
forall srcpkg. srcpkg -> GenericReadyPackage srcpkg
ReadyPackage ElaboratedConfiguredPackage
elab)
                    ElaboratedSharedConfig
elaboratedShared
                    CommonSetupFlags
commonFlags
                )
            -- \| Given a default value @x@ for a flag, nub @Flag x@
            -- into @NoFlag@.  This gives us a tidier command line
            -- rendering.
            nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a
            nubFlag :: forall a. Eq a => a -> Flag a -> Flag a
nubFlag a
x (Setup.Flag a
x') | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x' = Last a
forall a. Last a
Setup.NoFlag
            nubFlag a
_ Last a
f = Last a
f

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

            partialConfigureFlags :: ConfigFlags
partialConfigureFlags =
              ConfigFlags
forall a. Monoid a => a
mempty
                { configProf =
                    nubFlag False (configProf fullConfigureFlags)
                , configProfExe =
                    nubFlag tryExeProfiling (configProfExe fullConfigureFlags)
                , configProfLib =
                    nubFlag tryLibProfiling (configProfLib fullConfigureFlags)
                , configProfShared =
                    nubFlag tryLibProfilingShared (configProfShared fullConfigureFlags)
                }
         in -- Not necessary to "escape" it, it's just for user output
            [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 :: forall a. 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
globalOptimization Flag OptimisationLevel
-> Flag OptimisationLevel -> Flag OptimisationLevel
forall a. Semigroup a => a -> a -> a
<> Flag OptimisationLevel
localOptimization of -- if local is not set, read global
                      Setup.Flag OptimisationLevel
NoOptimisation -> String
"0"
                      Setup.Flag OptimisationLevel
NormalOptimisation -> String
"1"
                      Setup.Flag OptimisationLevel
MaximumOptimisation -> String
"2"
                      Flag OptimisationLevel
Setup.NoFlag -> String
"1"
                   )
            ]
          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 PackageIdentifier
_ 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 BuildOutcome -> Maybe (BuildReport, Maybe Repo)
fromPlanPackage (InstallPlan.Configured ElaboratedConfiguredPackage
pkg) (Just BuildOutcome
result) =
        let installOutcome :: InstallOutcome
installOutcome = case BuildOutcome
result of
              Left BuildFailure
bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                GracefulFailure String
_ -> InstallOutcome
BuildReports.PlanningFailed
                DependentFailed PackageIdentifier
p -> PackageIdentifier -> InstallOutcome
BuildReports.DependencyFailed PackageIdentifier
p
                DownloadFailed SomeException
_ -> InstallOutcome
BuildReports.DownloadFailed
                UnpackFailed SomeException
_ -> InstallOutcome
BuildReports.UnpackFailed
                ConfigureFailed SomeException
_ -> InstallOutcome
BuildReports.ConfigureFailed
                BuildFailed SomeException
_ -> InstallOutcome
BuildReports.BuildFailed
                TestsFailed SomeException
_ -> InstallOutcome
BuildReports.TestsFailed
                InstallFailed SomeException
_ -> InstallOutcome
BuildReports.InstallFailed
                ReplFailed SomeException
_ -> InstallOutcome
BuildReports.InstallOk
                HaddocksFailed SomeException
_ -> InstallOutcome
BuildReports.InstallOk
                BenchFailed SomeException
_ -> InstallOutcome
BuildReports.InstallOk
              Right BuildResult
_br -> InstallOutcome
BuildReports.InstallOk

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

            testsOutcome :: Outcome
testsOutcome = case BuildOutcome
result of
              Left BuildFailure
bf -> case BuildFailure -> BuildFailureReason
buildFailureReason BuildFailure
bf of
                TestsFailed SomeException
_ -> Outcome
BuildReports.Failed
                BuildFailureReason
_ -> Outcome
BuildReports.NotTried
              Right BuildResult
br -> case BuildResult -> TestsResult
buildResultTests BuildResult
br of
                TestsResult
TestsNotTried -> Outcome
BuildReports.NotTried
                TestsResult
TestsOk -> Outcome
BuildReports.Ok
         in (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
$ (PackageIdentifier
-> OS
-> Arch
-> CompilerId
-> PackageIdentifier
-> FlagAssignment
-> [PackageIdentifier]
-> InstallOutcome
-> Outcome
-> Outcome
-> BuildReport
BuildReports.BuildReport (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg) OS
os Arch
arch (Compiler -> CompilerId
compilerId Compiler
comp) PackageIdentifier
cabalInstallID (ElaboratedConfiguredPackage -> FlagAssignment
elabFlagAssignment ElaboratedConfiguredPackage
pkg) (((ConfiguredId, Bool) -> PackageIdentifier)
-> [(ConfiguredId, Bool)] -> [PackageIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map (ConfiguredId -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId (ConfiguredId -> PackageIdentifier)
-> ((ConfiguredId, Bool) -> ConfiguredId)
-> (ConfiguredId, Bool)
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConfiguredId, Bool) -> ConfiguredId
forall a b. (a, b) -> a
fst) ([(ConfiguredId, Bool)] -> [PackageIdentifier])
-> [(ConfiguredId, Bool)] -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)]
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 BuildOutcome
_ = 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 BuildOutcome -> Maybe (BuildReport, Maybe Repo)
forall {ipkg}.
GenericPlanPackage ipkg ElaboratedConfiguredPackage
-> Maybe BuildOutcome -> Maybe (BuildReport, Maybe Repo)
fromPlanPackage GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
x (GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> BuildOutcomes -> Maybe BuildOutcome
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitId, BuildFailure)]
failures = () -> IO ()
forall a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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, BuildOutcome)]
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 Verbosity
verb String
str
      | CurrentCommand
currentCommand CurrentCommand -> CurrentCommand -> Bool
forall a. Eq a => a -> a -> Bool
== CurrentCommand
HaddockCommand = Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verb (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
DieIfNotHaddockFailureException String
str
      | ((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 Verbosity
verb String
str
      | Bool
otherwise = Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verb (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
DieIfNotHaddockFailureException String
str
      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 a. a -> Maybe a
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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CurrentCommand
InstallCommand, CurrentCommand
BuildCommand, CurrentCommand
ReplCommand] =
          Bool
True
      | Bool
otherwise =
          Bool
False

    -- NB: if the Setup script segfaulted or was interrupted,
    -- we should give more detailed information.  So only
    -- assume that exit code 1 is "pedestrian failure."
    isFailureSelfExplanatory :: BuildFailureReason -> Bool
    isFailureSelfExplanatory :: BuildFailureReason -> Bool
isFailureSelfExplanatory (BuildFailed SomeException
e)
      | Just (ExitFailure Int
1) <- 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 :: forall pkg. HasUnitId pkg => pkg -> Bool
hasNoDependents = [GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage]
-> Bool
forall a. [a] -> 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
        GracefulFailure String
msg -> String
msg
        DependentFailed PackageIdentifier
depid ->
          String
"Failed to build "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" because it depends on "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
forall a. Pretty a => a -> String
prettyShow PackageIdentifier
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
""

{- FOURMOLU_DISABLE -}
#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  "
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e

    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
        GracefulFailure String
_ -> Maybe SomeException
forall {a}. Maybe a
Nothing
        DependentFailed PackageIdentifier
_ -> Maybe SomeException
forall {a}. Maybe a
Nothing
{- FOURMOLU_ENABLE -}

data BuildFailurePresentation
  = ShowBuildSummaryOnly BuildFailureReason
  | ShowBuildSummaryAndLog BuildFailureReason FilePath

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

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

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

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

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

establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> String -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity ProjectConfig
cliConfig String
tmpDir = do
  let distDirLayout :: DistDirLayout
distDirLayout = ProjectRoot -> Maybe String -> Maybe String -> DistDirLayout
defaultDistDirLayout ProjectRoot
projectRoot Maybe String
mdistDirectory Maybe String
forall {a}. Maybe a
Nothing

  -- 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 a. a -> IO a
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