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

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

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

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

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

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

    -- * Post build actions
    runProjectPostBuildPhase,
    dieOnBuildFailures,

    -- * Dummy projects
    establishDummyProjectBaseContext,
    establishDummyDistDirLayout,
  ) where

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

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

import           Distribution.Client.TargetProblem
                   ( TargetProblem (..) )
import           Distribution.Client.Types
                   ( GenericReadyPackage(..), UnresolvedSourcePackage
                   , PackageSpecifier(..)
                   , SourcePackageDb(..)
                   , WriteGhcEnvironmentFilesPolicy(..) )
import           Distribution.Solver.Types.PackageIndex
                   ( lookupPackageName )
import qualified Distribution.Client.InstallPlan as InstallPlan
import           Distribution.Client.TargetSelector
                   ( TargetSelector(..), TargetImplicitCwd(..)
                   , ComponentKind(..), componentKind
                   , readTargetSelectors, reportTargetSelectorProblems )
import           Distribution.Client.DistDirLayout
import           Distribution.Client.Config (getCabalDir)
import           Distribution.Client.Setup hiding (packageName)
import           Distribution.Compiler
                   ( CompilerFlavor(GHC) )
import           Distribution.Types.ComponentName
                   ( componentNameString )
import           Distribution.Types.UnqualComponentName
                   ( UnqualComponentName, packageNameToUnqualComponentName )

import           Distribution.Solver.Types.OptionalStanza

import           Distribution.Package
import           Distribution.Types.Flag
                   ( FlagAssignment, showFlagAssignment, diffFlagAssignment )
import           Distribution.Simple.LocalBuildInfo
                   ( ComponentName(..), pkgComponents )
import           Distribution.Simple.Flag
                   ( fromFlagOrDefault, flagToMaybe )
import qualified Distribution.Simple.Setup as Setup
import           Distribution.Simple.Command (commandShowOptions)
import           Distribution.Simple.Configure (computeEffectiveProfiling)

import           Distribution.Simple.Utils
                   ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose )
import           Distribution.Verbosity
import           Distribution.Version
                   ( mkVersion )
import           Distribution.Simple.Compiler
                   ( compilerCompatVersion, showCompilerId
                   , OptimisationLevel(..))

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


-- | Tracks what command is being executed, because we need to hide this somewhere
-- for cases that need special handling (usually for error reporting).
data CurrentCommand = InstallCommand | HaddockCommand | OtherCommand
                    deriving (Show, Eq)

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

establishProjectBaseContext
    :: Verbosity
    -> ProjectConfig
    -> CurrentCommand
    -> IO ProjectBaseContext
establishProjectBaseContext verbosity cliConfig currentCommand = do
    projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile
    establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand
  where
    mprojectFile   = Setup.flagToMaybe projectConfigProjectFile
    ProjectConfigShared { projectConfigProjectFile } = projectConfigShared cliConfig

-- | Like 'establishProjectBaseContext' but doesn't search for project root.
establishProjectBaseContextWithRoot
    :: Verbosity
    -> ProjectConfig
    -> ProjectRoot
    -> CurrentCommand
    -> IO ProjectBaseContext
establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do
    cabalDir <- getCabalDir

    let distDirLayout  = defaultDistDirLayout projectRoot mdistDirectory

    (projectConfig, localPackages) <-
      rebuildProjectConfig verbosity
                           distDirLayout
                           cliConfig

    let ProjectConfigBuildOnly {
          projectConfigLogsDir
        } = projectConfigBuildOnly projectConfig

        ProjectConfigShared {
          projectConfigStoreDir
        } = projectConfigShared projectConfig

        mlogsDir = Setup.flagToMaybe projectConfigLogsDir
    mstoreDir <- sequenceA $ makeAbsolute
                 <$> Setup.flagToMaybe projectConfigStoreDir
    let cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir

        buildSettings = resolveBuildTimeSettings
                          verbosity cabalDirLayout
                          projectConfig

    -- https://github.com/haskell/cabal/issues/6013
    when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $
        warn verbosity "There are no packages or optional-packages in the project"

    return ProjectBaseContext {
      distDirLayout,
      cabalDirLayout,
      projectConfig,
      localPackages,
      buildSettings,
      currentCommand
    }
  where
    mdistDirectory = Setup.flagToMaybe projectConfigDistDir
    ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig


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

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

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

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

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


-- | Pre-build phase: decide what to do.
--
withInstallPlan
    :: Verbosity
    -> ProjectBaseContext
    -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
    -> IO a
withInstallPlan
    verbosity
    ProjectBaseContext {
      distDirLayout,
      cabalDirLayout,
      projectConfig,
      localPackages
    }
    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.
    --
    (elaboratedPlan, _, elaboratedShared, _, _) <-
      rebuildInstallPlan verbosity
                         distDirLayout cabalDirLayout
                         projectConfig
                         localPackages
    action elaboratedPlan elaboratedShared

runProjectPreBuildPhase
    :: Verbosity
    -> ProjectBaseContext
    -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
    -> IO ProjectBuildContext
runProjectPreBuildPhase
    verbosity
    ProjectBaseContext {
      distDirLayout,
      cabalDirLayout,
      projectConfig,
      localPackages
    }
    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.
    --
    (elaboratedPlan, _, elaboratedShared, _, _) <-
      rebuildInstallPlan verbosity
                         distDirLayout cabalDirLayout
                         projectConfig
                         localPackages

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

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

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

    -- Improve the plan by marking up-to-date packages as installed.
    --
    let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages
                             pkgsBuildStatus elaboratedPlan'
    debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')

    return ProjectBuildContext {
      elaboratedPlanOriginal = elaboratedPlan,
      elaboratedPlanToExecute = elaboratedPlan'',
      elaboratedShared,
      pkgsBuildStatus,
      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 _ ProjectBaseContext{buildSettings} _
  | buildSettingDryRun buildSettings
  = return Map.empty

runProjectBuildPhase verbosity
                     ProjectBaseContext{..} ProjectBuildContext {..} =
    fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $
    rebuildTargets verbosity
                   distDirLayout
                   (cabalStoreDirLayout cabalDirLayout)
                   elaboratedPlanToExecute
                   elaboratedShared
                   pkgsBuildStatus
                   buildSettings
  where
    previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
    previousBuildOutcomes =
      Map.mapMaybe $ \status -> case status of
        BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)
        --TODO: [nice to have] record build failures persistently
        _                                  -> 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 _ ProjectBaseContext{buildSettings} _ _
  | buildSettingDryRun buildSettings
  = return ()

runProjectPostBuildPhase verbosity
                         ProjectBaseContext {..} ProjectBuildContext {..}
                         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

    postBuildStatus <- updatePostBuildProjectStatus
                         verbosity
                         distDirLayout
                         elaboratedPlanOriginal
                         pkgsBuildStatus
                         buildOutcomes

    -- Write the .ghc.environment file (if allowed by the env file write policy).
    let writeGhcEnvFilesPolicy =
          projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared
          $ projectConfig

        shouldWriteGhcEnvironment =
          case fromFlagOrDefault NeverWriteGhcEnvironmentFiles
               writeGhcEnvFilesPolicy
          of
            AlwaysWriteGhcEnvironmentFiles                -> True
            NeverWriteGhcEnvironmentFiles                 -> False
            WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->
              let compiler         = pkgConfigCompiler elaboratedShared
                  ghcCompatVersion = compilerCompatVersion GHC compiler
              in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion

    when shouldWriteGhcEnvironment $
      void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout)
                                     elaboratedPlanOriginal
                                     elaboratedShared
                                     postBuildStatus

    -- Finally if there were any build failures then report them and throw
    -- an exception to terminate the program
    dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes

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

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


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

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

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

    AvailableTargetIndexes{..} = availableTargetIndexes installPlan

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

    -- We can ask to build any whole package, project-local or a dependency
    checkTarget bt@(TargetPackage _ [pkgid] mkfilter)
      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)
                  $ Map.lookup pkgid availableTargetsByPackageId
      = fmap (componentTargets WholeComponent)
      $ selectPackageTargets bt ats

      | otherwise
      = Left (TargetProblemNoSuchPackage pkgid)

    checkTarget (TargetPackage _ pkgids _)
      = error ("TODO: add support for multiple packages in a directory.  Got\n"
              ++ unlines (map prettyShow 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@(TargetAllPackages mkfilter) =
        fmap (componentTargets WholeComponent)
      . selectPackageTargets bt
      . maybe id filterTargetsKind mkfilter
      . filter availableTargetLocalToProject
      $ concat (Map.elems availableTargetsByPackageId)

    checkTarget (TargetComponent pkgid cname subtarget)
      | Just ats <- Map.lookup (pkgid, cname)
                               availableTargetsByPackageIdAndComponentName
      = fmap (componentTargets subtarget)
      $ selectComponentTargets subtarget ats

      | Map.member pkgid availableTargetsByPackageId
      = Left (TargetProblemNoSuchComponent pkgid cname)

      | otherwise
      = Left (TargetProblemNoSuchPackage pkgid)

    checkTarget (TargetComponentUnknown pkgname ecname subtarget)
      | Just ats <- case ecname of
          Left ucname ->
            Map.lookup (pkgname, ucname)
                       availableTargetsByPackageNameAndUnqualComponentName
          Right cname ->
            Map.lookup (pkgname, cname)
                       availableTargetsByPackageNameAndComponentName
      = fmap (componentTargets subtarget)
      $ selectComponentTargets subtarget ats

      | Map.member pkgname availableTargetsByPackageName
      = Left (TargetProblemUnknownComponent pkgname ecname)

      | otherwise
      = Left (TargetNotInProject pkgname)

    checkTarget bt@(TargetPackageNamed pkgname mkfilter)
      | Just ats <- fmap (maybe id filterTargetsKind mkfilter)
                  $ Map.lookup pkgname availableTargetsByPackageName
      = fmap (componentTargets WholeComponent)
      . selectPackageTargets bt
      $ ats

      | Just SourcePackageDb{ packageIndex } <- mPkgDb
      , let pkg = lookupPackageName packageIndex pkgname
      , not (null pkg)
      = Left (TargetAvailableInIndex pkgname)

      | otherwise
      = Left (TargetNotInProject pkgname)

    componentTargets :: SubComponentTarget
                     -> [(b, ComponentName)]
                     -> [(b, ComponentTarget)]
    componentTargets subtarget =
      map (fmap (\cname -> ComponentTarget cname subtarget))

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

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


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

       availableTargetsByPackageId
         :: AvailableTargetsMap PackageId,

       availableTargetsByPackageName
         :: AvailableTargetsMap PackageName,

       availableTargetsByPackageNameAndComponentName
         :: AvailableTargetsMap (PackageName, ComponentName),

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

-- We define a bunch of indexes to help 'resolveTargets' with resolving
-- 'TargetSelector's to specific 'UnitId's.
--
-- They are all derived from the 'availableTargets' index.
-- The 'availableTargetsByPackageIdAndComponentName' is just that main index,
-- while the others are derived by re-grouping on the index key.
--
-- They are all constructed lazily because they are not necessarily all used.
--
availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes
availableTargetIndexes installPlan = AvailableTargetIndexes{..}
  where
    availableTargetsByPackageIdAndComponentName =
      availableTargets installPlan

    availableTargetsByPackageId =
                  Map.mapKeysWith
                    (++) (\(pkgid, _cname) -> pkgid)
                    availableTargetsByPackageIdAndComponentName
      `Map.union` availableTargetsEmptyPackages

    availableTargetsByPackageName =
      Map.mapKeysWith
        (++) packageName
        availableTargetsByPackageId

    availableTargetsByPackageNameAndComponentName =
      Map.mapKeysWith
        (++) (\(pkgid, cname) -> (packageName pkgid, cname))
        availableTargetsByPackageIdAndComponentName

    availableTargetsByPackageNameAndUnqualComponentName =
      Map.mapKeysWith
        (++) (\(pkgid, cname) -> let pname  = packageName pkgid
                                     cname' = unqualComponentName pname cname
                                  in (pname, cname'))
        availableTargetsByPackageIdAndComponentName
     where
       unqualComponentName ::
         PackageName -> ComponentName -> UnqualComponentName
       unqualComponentName pkgname =
           fromMaybe (packageNameToUnqualComponentName pkgname)
         . 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.fromList
        [ (packageId pkg, [])
        | InstallPlan.Configured pkg <- InstallPlan.toList installPlan
        , case elabPkgOrComp pkg of
            ElabComponent _ -> False
            ElabPackage   _ -> null (pkgComponents (elabPkgDescription pkg))
        ]

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

filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ckind = filterTargetsKindWith (== ckind)

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

selectBuildableTargets :: [AvailableTarget k] -> [k]
selectBuildableTargets ts =
    [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]

selectBuildableTargetsWith :: (TargetRequested -> Bool)
                          -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith p ts =
    [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]

selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets' ts =
    (,) [ k | AvailableTarget _ _ (TargetBuildable k _) _ <- ts ]
        [ forgetTargetDetail t
        | t@(AvailableTarget _ _ (TargetBuildable _ _) _) <- ts ]

selectBuildableTargetsWith' :: (TargetRequested -> Bool)
                           -> [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith' p ts =
    (,) [ k | AvailableTarget _ _ (TargetBuildable k req) _ <- ts, p req ]
        [ forgetTargetDetail t
        | t@(AvailableTarget _ _ (TargetBuildable _ req) _) <- ts, p req ]


forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()
forgetTargetDetail = fmap (const ())

forgetTargetsDetail :: [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail = map 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 subtarget
                           AvailableTarget {
                             availableTargetPackageId     = pkgid,
                             availableTargetComponentName = cname,
                             availableTargetStatus
                           } =
    case availableTargetStatus of
      TargetDisabledByUser ->
        Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget)

      TargetDisabledBySolver ->
        Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget)

      TargetNotLocal ->
        Left (TargetComponentNotProjectLocal pkgid cname subtarget)

      TargetNotBuildable ->
        Left (TargetComponentNotBuildable pkgid cname subtarget)

      TargetBuildable targetKey _ ->
        Right targetKey

-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts
-- for the extra unneeded info in the 'TargetsMap'.
--
pruneInstallPlanToTargets :: TargetAction -> TargetsMap
                          -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =
    assert (Map.size targetsMap > 0) $
    ProjectPlanning.pruneInstallPlanToTargets
      targetActionType
      (Map.map (map fst) targetsMap)
      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.fromList [ (uid, cname)
                 | (uid, cts) <- Map.toList targetsMap
                 , (ComponentTarget cname _, _) <- 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 {
            buildSettings = BuildTimeSettings{buildSettingDryRun},
            projectConfig = ProjectConfig {
              projectConfigLocalPackages =
                  PackageConfig {packageConfigOptimization}
            }
          }
          ProjectBuildContext {
            elaboratedPlanToExecute = elaboratedPlan,
            elaboratedShared,
            pkgsBuildStatus
          }

  | null pkgs
  = notice verbosity "Up to date"

  | otherwise
  = noticeNoWrap verbosity $ unlines $
      (showBuildProfile ++ "In order, the following "
       ++ wouldWill ++ " be built"
       ++ ifNormal " (use -v for more details)" ++ ":")
    : map showPkgAndReason pkgs

  where
    pkgs = InstallPlan.executionOrder elaboratedPlan

    ifVerbose s | verbosity >= verbose = s
                | otherwise            = ""

    ifNormal s | verbosity >= verbose = ""
               | otherwise            = s

    wouldWill | buildSettingDryRun = "would"
              | otherwise          = "will"

    showPkgAndReason :: ElaboratedReadyPackage -> String
    showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $
      [ " -"
      , if verbosity >= deafening
        then prettyShow (installedUnitId elab)
        else prettyShow (packageId elab)
      , case elabPkgOrComp elab of
          ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas pkg)
          ElabComponent comp ->
            "(" ++ showComp elab comp ++ ")"
      , showFlagAssignment (nonDefaultFlags elab)
      , showConfigureFlags elab
      , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
        in "(" ++ showBuildStatus buildStatus ++ ")"
      ]

    showComp elab comp =
        maybe "custom" prettyShow (compComponentName comp) ++
        if Map.null (elabInstantiatedWith elab)
            then ""
            else " with " ++
                intercalate ", "
                    -- TODO: Abbreviate the UnitIds
                    [ prettyShow k ++ "=" ++ prettyShow v
                    | (k,v) <- Map.toList (elabInstantiatedWith elab) ]

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

    showStanzas pkg = concat
                    $ [ " *test"
                      | TestStanzas  `Set.member` pkgStanzasEnabled pkg ]
                   ++ [ " *bench"
                      | BenchStanzas `Set.member` pkgStanzasEnabled pkg ]

    showTargets elab
      | null (elabBuildTargets elab) = ""
      | otherwise
      = "("
        ++ intercalate ", " [ showComponentTarget (packageId elab) t
                            | t <- elabBuildTargets elab ]
        ++ ")"

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

            (tryLibProfiling, tryExeProfiling) =
              computeEffectiveProfiling fullConfigureFlags

            partialConfigureFlags
              = mempty {
                configProf    =
                    nubFlag False (configProf fullConfigureFlags),
                configProfExe =
                    nubFlag tryExeProfiling (configProfExe fullConfigureFlags),
                configProfLib =
                    nubFlag tryLibProfiling (configProfLib fullConfigureFlags)
                -- Maybe there are more we can add
              }
        -- Not necessary to "escape" it, it's just for user output
        in unwords . ("":) $
            commandShowOptions
            (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
            partialConfigureFlags

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

    showMonitorChangedReason (MonitoredFileChanged file) =
      "file " ++ file ++ " changed"
    showMonitorChangedReason (MonitoredValueChanged _)   = "value changed"
    showMonitorChangedReason  MonitorFirstRun            = "first run"
    showMonitorChangedReason  MonitorCorruptCache        =
      "cannot read state cache"

    showBuildProfile = "Build profile: " ++ unwords [
      "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,
      "-O" ++  (case packageConfigOptimization of
                Setup.Flag NoOptimisation      -> "0"
                Setup.Flag NormalOptimisation  -> "1"
                Setup.Flag MaximumOptimisation -> "2"
                Setup.NoFlag                   -> "1")]
      ++ "\n"

-- | If there are build failures then report them and throw an exception.
--
dieOnBuildFailures :: Verbosity -> CurrentCommand
                   -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
dieOnBuildFailures verbosity currentCommand plan buildOutcomes
  | null failures = return ()

  | isSimpleCase  = exitFailure

  | otherwise = do
      -- For failures where we have a build log, print the log plus a header
       sequence_
         [ do notice verbosity $
                '\n' : renderFailureDetail False pkg reason
                    ++ "\nBuild log ( " ++ logfile ++ " ):"
              readFile logfile >>= noticeNoWrap verbosity
         | (pkg, ShowBuildSummaryAndLog reason logfile)
             <- failuresClassification
         ]

       -- For all failures, print either a short summary (if we showed the
       -- build log) or all details
       dieIfNotHaddockFailure verbosity $ unlines
         [ case failureClassification of
             ShowBuildSummaryAndLog reason _
               | verbosity > normal
              -> renderFailureDetail mentionDepOf pkg reason

               | otherwise
              -> renderFailureSummary mentionDepOf pkg reason
              ++ ". See the build log above for details."

             ShowBuildSummaryOnly reason ->
               renderFailureDetail mentionDepOf pkg reason

         | let mentionDepOf = verbosity <= normal
         , (pkg, failureClassification) <- failuresClassification ]
  where
    failures =  [ (pkgid, failure)
                | (pkgid, Left failure) <- Map.toList buildOutcomes ]

    failuresClassification =
      [ (pkg, classifyBuildFailure failure)
      | (pkgid, failure) <- failures
      , case buildFailureReason failure of
          DependentFailed {} -> verbosity > normal
          _                  -> True
      , InstallPlan.Configured pkg <-
           maybeToList (InstallPlan.lookup plan pkgid)
      ]

    dieIfNotHaddockFailure
      | currentCommand == HaddockCommand            = die'
      | all isHaddockFailure failuresClassification = warn
      | otherwise                                   = die'
      where
        isHaddockFailure
          (_, ShowBuildSummaryOnly   (HaddocksFailed _)  ) = True
        isHaddockFailure
          (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True
        isHaddockFailure
          _                                                = False


    classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
    classifyBuildFailure BuildFailure {
                           buildFailureReason  = reason,
                           buildFailureLogFile = mlogfile
                         } =
      maybe (ShowBuildSummaryOnly   reason)
            (ShowBuildSummaryAndLog reason) $ do
        logfile <- mlogfile
        e       <- buildFailureException reason
        ExitFailure 1 <- fromException e
        return 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
      | [(pkgid, failure)] <- failures
      , [pkg]              <- rootpkgs
      , installedUnitId pkg == pkgid
      , isFailureSelfExplanatory (buildFailureReason failure)
      , currentCommand /= InstallCommand
      = True
      | otherwise
      = 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 (BuildFailed e)
      | Just (ExitFailure 1) <- fromException e = True

    isFailureSelfExplanatory (ConfigureFailed e)
      | Just (ExitFailure 1) <- fromException e = True

    isFailureSelfExplanatory _                  = False

    rootpkgs =
      [ pkg
      | InstallPlan.Configured pkg <- InstallPlan.toList plan
      , hasNoDependents pkg ]

    ultimateDeps pkgid =
        filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
               (InstallPlan.reverseDependencyClosure plan [pkgid])

    hasNoDependents :: HasUnitId pkg => pkg -> Bool
    hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId

    renderFailureDetail mentionDepOf pkg reason =
        renderFailureSummary mentionDepOf pkg reason ++ "."
     ++ renderFailureExtraDetail reason
     ++ maybe "" showException (buildFailureException reason)

    renderFailureSummary mentionDepOf pkg reason =
        case reason of
          DownloadFailed  _ -> "Failed to download " ++ pkgstr
          UnpackFailed    _ -> "Failed to unpack "   ++ pkgstr
          ConfigureFailed _ -> "Failed to build "    ++ pkgstr
          BuildFailed     _ -> "Failed to build "    ++ pkgstr
          ReplFailed      _ -> "repl failed for "    ++ pkgstr
          HaddocksFailed  _ -> "Failed to build documentation for " ++ pkgstr
          TestsFailed     _ -> "Tests failed for " ++ pkgstr
          BenchFailed     _ -> "Benchmarks failed for " ++ pkgstr
          InstallFailed   _ -> "Failed to build "  ++ pkgstr
          DependentFailed depid
                            -> "Failed to build " ++ prettyShow (packageId pkg)
                            ++ " because it depends on " ++ prettyShow depid
                            ++ " which itself failed to build"
      where
        pkgstr = elabConfiguredName verbosity pkg
              ++ if mentionDepOf
                   then renderDependencyOf (installedUnitId pkg)
                   else ""

    renderFailureExtraDetail (ConfigureFailed _) =
      " The failure occurred during the configure step."
    renderFailureExtraDetail (InstallFailed   _) =
      " The failure occurred during the final install step."
    renderFailureExtraDetail _                   =
      ""

    renderDependencyOf pkgid =
      case ultimateDeps pkgid of
        []         -> ""
        (p1:[])    ->
          " (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"
        (p1:p2:[]) ->
          " (which is required by " ++ elabPlanPackageName verbosity p1
          ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")"
        (p1:p2:_)  ->
          " (which is required by " ++ elabPlanPackageName verbosity p1
          ++ ", " ++ elabPlanPackageName verbosity p2
          ++ " and others)"

    showException e = case fromException e of
      Just (ExitFailure 1) -> ""

#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 n)
        | -n == fromIntegral sigSEGV ->
            " The build process segfaulted (i.e. SIGSEGV)."

        |  n == fromIntegral sigSEGV ->
            " The build process terminated with exit code " ++ show n
         ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."

        | -n == fromIntegral sigKILL ->
            " The build process was killed (i.e. SIGKILL). " ++ explanation

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

      _ -> " The exception was:\n  "
#if MIN_VERSION_base(4,8,0)
             ++ displayException e
#else
             ++ show e
#endif

    buildFailureException reason =
      case reason of
        DownloadFailed  e -> Just e
        UnpackFailed    e -> Just e
        ConfigureFailed e -> Just e
        BuildFailed     e -> Just e
        ReplFailed      e -> Just e
        HaddocksFailed  e -> Just e
        TestsFailed     e -> Just e
        BenchFailed     e -> Just e
        InstallFailed   e -> Just e
        DependentFailed _ -> Nothing

data BuildFailurePresentation =
       ShowBuildSummaryOnly   BuildFailureReason
     | ShowBuildSummaryAndLog BuildFailureReason FilePath

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

-- | Create a dummy project context, without a .cabal or a .cabal.project file
-- (a place where to put a temporary dist directory is still needed)
establishDummyProjectBaseContext
  :: Verbosity
  -> ProjectConfig
  -> DistDirLayout
     -- ^ Where to put the dist directory
  -> [PackageSpecifier UnresolvedSourcePackage]
     -- ^ The packages to be included in the project
  -> CurrentCommand
  -> IO ProjectBaseContext
establishDummyProjectBaseContext verbosity cliConfig distDirLayout localPackages currentCommand = do
    cabalDir <- getCabalDir

    globalConfig <- runRebuild ""
                  $ readGlobalConfig verbosity
                  $ projectConfigConfigFile
                  $ projectConfigShared cliConfig
    let projectConfig = globalConfig <> cliConfig

    let ProjectConfigBuildOnly {
          projectConfigLogsDir
        } = projectConfigBuildOnly projectConfig

        ProjectConfigShared {
          projectConfigStoreDir
        } = projectConfigShared projectConfig

        mlogsDir = flagToMaybe projectConfigLogsDir
        mstoreDir = flagToMaybe projectConfigStoreDir
        cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir

        buildSettings = resolveBuildTimeSettings
                          verbosity cabalDirLayout
                          projectConfig

    return ProjectBaseContext {
      distDirLayout,
      cabalDirLayout,
      projectConfig,
      localPackages,
      buildSettings,
      currentCommand
    }

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

    -- Create the dist directories
    createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
    createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout

    return distDirLayout
  where
    mdistDirectory = flagToMaybe
                   $ projectConfigDistDir
                   $ projectConfigShared cliConfig
    projectRoot = ProjectRootImplicit tmpDir
