CmdInstall.hs

{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | cabal-install CLI command: build
--
module Distribution.Client.CmdInstall (
    -- * The @build@ CLI and action
    installCommand,
    installAction,

    -- * Internals exposed for testing
    selectPackageTargets,
    selectComponentTarget,
    -- * Internals exposed for CmdRepl + CmdRun
    establishDummyDistDirLayout,
    establishDummyProjectBaseContext
  ) where

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

import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdSdist
import Distribution.Client.TargetProblem
         ( TargetProblem', TargetProblem (..) )

import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.CmdInstall.ClientInstallTargetSelector

import Distribution.Client.Setup
         ( GlobalFlags(..), ConfigFlags(..), InstallFlags(..) )
import Distribution.Client.Types
         ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage
         , SourcePackageDb(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
         ( Package(..), PackageName, mkPackageName, unPackageName )
import Distribution.Types.PackageId
         ( PackageIdentifier(..) )
import Distribution.Client.ProjectConfig
         ( ProjectPackageLocation(..)
         , fetchAndReadSourcePackages
         , projectConfigWithBuilderRepoContext
         , resolveBuildTimeSettings, withProjectOrGlobalConfig )
import Distribution.Client.NixStyleOptions
         ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.ProjectFlags (ProjectFlags (..))
import Distribution.Client.ProjectConfig.Types
         ( ProjectConfig(..), ProjectConfigShared(..)
         , ProjectConfigBuildOnly(..), PackageConfig(..)
         , MapMappend(..)
         , getMapLast, getMapMappend, projectConfigLogsDir
         , projectConfigStoreDir, projectConfigBuildOnly
         , projectConfigConfigFile )
import Distribution.Simple.Program.Db
         ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
         , appendProgramSearchPath )
import Distribution.Simple.BuildPaths
         ( exeExtension )
import Distribution.Client.Config
         ( defaultInstallPath, loadConfig, SavedConfig(..) )
import qualified Distribution.Simple.PackageIndex as PI
import Distribution.Solver.Types.PackageIndex
         ( lookupPackageName, searchByName )
import Distribution.Types.InstalledPackageInfo
         ( InstalledPackageInfo(..) )
import Distribution.Types.Version
         ( Version, nullVersion )
import Distribution.Types.VersionRange
         ( thisVersion )
import Distribution.Solver.Types.PackageConstraint
         ( PackageProperty(..) )
import Distribution.Client.IndexUtils
         ( getSourcePackages, getInstalledPackages )
import Distribution.Client.ProjectPlanning
         ( storePackageInstallDirs' )
import Distribution.Client.ProjectPlanning.Types
         ( ElaboratedInstallPlan )
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Client.DistDirLayout
         ( DistDirLayout(..), mkCabalDirLayout
         , cabalStoreDirLayout
         , CabalDirLayout(..), StoreDirLayout(..) )
import Distribution.Client.RebuildMonad
         ( runRebuild )
import Distribution.Client.InstallSymlink
         ( symlinkBinary, trySymlink, promptRun )
import Distribution.Client.Types.OverwritePolicy
         ( OverwritePolicy (..) )
import Distribution.Simple.Flag
         ( fromFlagOrDefault, flagToMaybe, flagElim )
import Distribution.Simple.Setup
         ( Flag(..), installDirsOptions )
import Distribution.Solver.Types.SourcePackage
         ( SourcePackage(..) )
import Distribution.Simple.Command
         ( CommandUI(..), usageAlternatives, optionName )
import Distribution.Simple.Configure
         ( configCompilerEx )
import Distribution.Simple.Compiler
         ( Compiler(..), CompilerId(..), CompilerFlavor(..)
         , PackageDBStack, PackageDB(..) )
import Distribution.Simple.GHC
         ( ghcPlatformAndVersionString, getGhcAppDir
         , GhcImplInfo(..), getImplInfo
         , GhcEnvironmentFileEntry(..)
         , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
import Distribution.System
         ( Platform , buildOS, OS (Windows) )
import Distribution.Types.UnitId
         ( UnitId )
import Distribution.Types.UnqualComponentName
         ( UnqualComponentName, unUnqualComponentName )
import Distribution.Verbosity
         ( normal, lessVerbose )
import Distribution.Simple.Utils
         ( wrapText, die', notice, warn
         , withTempDirectory, createDirectoryIfMissingVerbose
         , ordNub, safeHead )
import Distribution.Utils.Generic
         ( writeFileAtomic )

import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Ord
         ( Down(..) )
import qualified Data.Map as Map
import qualified Data.Set as S
import qualified Data.List.NonEmpty as NE
import Distribution.Utils.NubList
         ( fromNubList )
import Network.URI (URI)
import System.Directory
         ( doesFileExist, createDirectoryIfMissing
         , getTemporaryDirectory, makeAbsolute, doesDirectoryExist
         , removeFile, removeDirectory, copyFile )
import System.FilePath
         ( (</>), (<.>), takeDirectory, takeBaseName )

installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
installCommand = CommandUI
  { commandName         = "v2-install"
  , commandSynopsis     = "Install packages."
  , commandUsage        = usageAlternatives
                          "v2-install" [ "[TARGETS] [FLAGS]" ]
  , commandDescription  = Just $ \_ -> wrapText $
    "Installs one or more packages. This is done by installing them "
    ++ "in the store and symlinking/copying the executables in the directory "
    ++ "specified by the --installdir flag (`~/.local/bin/` by default). "
    ++ "If you want the installed executables to be available globally, "
    ++ "make sure that the PATH environment variable contains that directory. "
    ++ "\n\n"
    ++ "If TARGET is a library and --lib (provisional) is used, "
    ++ "it will be added to the global environment. "
    ++ "When doing this, cabal will try to build a plan that includes all "
    ++ "the previously installed libraries. This is currently not implemented."
  , commandNotes        = Just $ \pname ->
      "Examples:\n"
      ++ "  " ++ pname ++ " v2-install\n"
      ++ "    Install the package in the current directory\n"
      ++ "  " ++ pname ++ " v2-install pkgname\n"
      ++ "    Install the package named pkgname"
      ++ " (fetching it from hackage if necessary)\n"
      ++ "  " ++ pname ++ " v2-install ./pkgfoo\n"
      ++ "    Install the package in the ./pkgfoo directory\n"

  , commandOptions      = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x
  , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags
  }
 where
  -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.
  notInstallDirOpt x = not $ optionName x `elem` installDirOptNames
  installDirOptNames = map optionName installDirsOptions


-- | The @install@ command actually serves four different needs. It installs:
-- * exes:
--   For example a program from hackage. The behavior is similar to the old
--   install command, except that now conflicts between separate runs of the
--   command are impossible thanks to the store.
--   Exes are installed in the store like a normal dependency, then they are
--   symlinked/copied in the directory specified by --installdir.
--   To do this we need a dummy projectBaseContext containing the targets as
--   extra packages and using a temporary dist directory.
-- * libraries
--   Libraries install through a similar process, but using GHC environment
--   files instead of symlinks. This means that 'v2-install'ing libraries
--   only works on GHC >= 8.0.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
--
installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do
  -- Ensure there were no invalid configuration options specified.
  verifyPreconditionsOrDie verbosity configFlags'

  -- We cannot use establishDummyProjectBaseContext to get these flags, since
  -- it requires one of them as an argument. Normal establishProjectBaseContext
  -- does not, and this is why this is done only for the install command
  clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'

  let
    installLibs    = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
    targetFilter   = if installLibs then Just LibKind else Just ExeKind
    targetStrings' = if null targetStrings then ["."] else targetStrings

    -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris.
    -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where
    -- no project file is present (including an implicit one derived from being in a package directory)
    -- or where the --ignore-project flag is passed explicitly. In such a case we only parse colon-free target selectors
    -- as selectors, and otherwise parse things as URIs.

    -- However, in the special case where --ignore-project is passed with no selectors, we want to act as though this is
    -- a "normal" ignore project that actually builds and installs the selected package.

    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
    withProject = do
      let reducedVerbosity = lessVerbose verbosity

      -- First, we need to learn about what's available to be installed.
      localBaseCtx <-
        establishProjectBaseContext reducedVerbosity cliConfig InstallCommand
      let localDistDirLayout = distDirLayout localBaseCtx
      pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity
               (buildSettings localBaseCtx) (getSourcePackages verbosity)

      let
        (targetStrings'', packageIds) =
          partitionEithers .
          flip fmap targetStrings' $
          \str -> case simpleParsec str of
            Just (pkgId :: PackageId)
              | pkgVersion pkgId /= nullVersion -> Right pkgId
            _                                   -> Left str
        packageSpecifiers =
          flip fmap packageIds $ \case
          PackageIdentifier{..}
            | pkgVersion == nullVersion -> NamedPackage pkgName []
            | otherwise                 -> NamedPackage pkgName
                                           [PackagePropertyVersion
                                            (thisVersion pkgVersion)]
        packageTargets =
          flip TargetPackageNamed targetFilter . pkgName <$> packageIds

      if null targetStrings'' -- if every selector is already resolved as a packageid, return without further parsing.
        then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)
        else do
          targetSelectors <-
            either (reportTargetSelectorProblems verbosity) return
            =<< readTargetSelectors (localPackages localBaseCtx)
                                    Nothing targetStrings''

          (specs, selectors) <-
            getSpecsAndTargetSelectors
              verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter

          return ( specs ++ packageSpecifiers
                 , []
                 , selectors ++ packageTargets
                 , projectConfig localBaseCtx )

    withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
    withoutProject _ | null targetStrings = withProject -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir
    withoutProject globalConfig = do
      tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'
      let
        projectConfig = globalConfig <> cliConfig

        ProjectConfigBuildOnly {
          projectConfigLogsDir
        } = projectConfigBuildOnly projectConfig

        ProjectConfigShared {
          projectConfigStoreDir
        } = projectConfigShared projectConfig

        mlogsDir = flagToMaybe projectConfigLogsDir
        mstoreDir = flagToMaybe projectConfigStoreDir
      cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir

      let
        buildSettings = resolveBuildTimeSettings
                          verbosity cabalDirLayout
                          projectConfig

      SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext
                                            verbosity buildSettings
                                            (getSourcePackages verbosity)

      for_ (concatMap woPackageNames tss) $ \name -> do
        when (null (lookupPackageName packageIndex name)) $ do
          let xs = searchByName packageIndex (unPackageName name)
          let emptyIf True  _  = []
              emptyIf False zs = zs
          die' verbosity $ concat $
            [ "Unknown package \"", unPackageName name, "\". "
            ] ++ emptyIf (null xs)
            [ "Did you mean any of the following?\n"
            , unlines (("- " ++) . unPackageName . fst <$> xs)
            ]

      let
        (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
        packageTargets            = map woPackageTargets tss

      return (packageSpecifiers, uris, packageTargets, projectConfig)

  (specs, uris, targetSelectors, config) <-
     withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject

  let
    ProjectConfig {
      projectConfigBuildOnly = ProjectConfigBuildOnly {
        projectConfigLogsDir
      },
      projectConfigShared = ProjectConfigShared {
        projectConfigHcFlavor,
        projectConfigHcPath,
        projectConfigHcPkg,
        projectConfigStoreDir,
        projectConfigProgPathExtra
      },
      projectConfigLocalPackages = PackageConfig {
        packageConfigProgramPaths,
        packageConfigProgramArgs,
        packageConfigProgramPathExtra
      }
    } = config

    hcFlavor = flagToMaybe projectConfigHcFlavor
    hcPath   = flagToMaybe projectConfigHcPath
    hcPkg    = flagToMaybe projectConfigHcPkg

  configProgDb <- appendProgramSearchPath verbosity ((fromNubList packageConfigProgramPathExtra) ++ (fromNubList projectConfigProgPathExtra)) defaultProgramDb
  let
    -- ProgramDb with directly user specified paths
    preProgDb =
      userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
        . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
        $ configProgDb

  -- progDb is a program database with compiler tools configured properly
  (compiler@Compiler { compilerId =
    compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <-
      configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity

  let
    GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler

  envFile <- getEnvFile clientInstallFlags platform compilerVersion
  existingEnvEntries <-
    getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
  packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb

  let
    (envSpecs, nonGlobalEnvEntries) =
      getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs

  -- Second, we need to use a fake project to let Cabal build the
  -- installables correctly. For that, we need a place to put a
  -- temporary dist directory.
  globalTmp <- getTemporaryDirectory

  withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do
    distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir

    uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages
      verbosity
      distDirLayout
      (projectConfigShared config)
      (projectConfigBuildOnly config)
      [ ProjectPackageRemoteTarball uri | uri <- uris ]

    -- check for targets already in env
    let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
        getPackageName (NamedPackage pn _) = pn
        getPackageName (SpecificSourcePackage (SourcePackage pkgId _ _ _)) = pkgName pkgId
        targetNames = S.fromList $ map getPackageName (specs ++ uriSpecs)
        envNames = S.fromList $ map getPackageName envSpecs
        forceInstall = fromFlagOrDefault False $ installOverrideReinstall installFlags
        nameIntersection = S.intersection targetNames envNames

    -- we check for intersections in targets with the existing env
    (envSpecs', nonGlobalEnvEntries') <- if null nameIntersection
      then pure (envSpecs, map snd nonGlobalEnvEntries)
      else if forceInstall
             then let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs
                      nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries
                  in pure (es, nge)
             else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection)

    -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that we can solve with regards to packages installed locally but not in the upstream repo
    let installedPacks = PI.allPackagesByName installedIndex
        newEnvNames = S.fromList $ map getPackageName envSpecs'
        installedIndex' = PI.fromList . concatMap snd . filter (\p -> fst p `S.member` newEnvNames) $ installedPacks

    baseCtx <- establishDummyProjectBaseContext
                 verbosity
                 config
                 distDirLayout
                 (envSpecs' ++ specs ++ uriSpecs)
                 InstallCommand

    buildCtx <- constructProjectBuildContext verbosity (baseCtx {installedPackages = Just installedIndex'}) targetSelectors

    printPlan verbosity baseCtx buildCtx

    buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
    runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes

    -- Now that we built everything we can do the installation part.
    -- First, figure out if / what parts we want to install:
    let
      dryRun = buildSettingDryRun (buildSettings baseCtx)
            || buildSettingOnlyDownload (buildSettings baseCtx)

    -- Then, install!
    unless dryRun $
      if installLibs
      then installLibraries verbosity
           buildCtx installedIndex compiler packageDbs envFile nonGlobalEnvEntries'
      else installExes verbosity
           baseCtx buildCtx platform compiler configFlags clientInstallFlags
  where
    configFlags' = disableTestsBenchsByDefault configFlags
    verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
    ignoreProject = flagIgnoreProject projectFlags
    baseCliConfig = commandLineFlagsToProjectConfig
                        globalFlags
                        flags { configFlags = configFlags' }
                        clientInstallFlags'
    cliConfig = addLocalConfigToTargets baseCliConfig targetStrings
    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)

-- | Treat all direct targets of install command as local packages: #8637
addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig
addLocalConfigToTargets config targetStrings
    = config {
        projectConfigSpecificPackage = projectConfigSpecificPackage config
                                       <> MapMappend (Map.fromList targetPackageConfigs)
    }
  where
    localConfig = projectConfigLocalPackages config
    targetPackageConfigs = map (\x -> (mkPackageName x, localConfig)) targetStrings

-- | Verify that invalid config options were not passed to the install command.
--
-- If an invalid configuration is found the command will @die'@.
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie verbosity configFlags = do
  -- We never try to build tests/benchmarks for remote packages.
  -- So we set them as disabled by default and error if they are explicitly
  -- enabled.
  when (configTests configFlags == Flag True) $
    die' verbosity $ "--enable-tests was specified, but tests can't "
                  ++ "be enabled in a remote package"
  when (configBenchmarks configFlags == Flag True) $
    die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "
                  ++ "be enabled in a remote package"

getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do
  let configFileFlag = globalConfigFile globalFlags
  savedConfig <- loadConfig verbosity configFileFlag
  pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags


getSpecsAndTargetSelectors
  :: Verbosity
  -> Verbosity
  -> SourcePackageDb
  -> [TargetSelector]
  -> DistDirLayout
  -> ProjectBaseContext
  -> Maybe ComponentKindFilter
  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =
  withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do
  -- Split into known targets and hackage packages.
  (targets, hackageNames) <-
    partitionToKnownTargetsAndHackagePackages
      verbosity pkgDb elaboratedPlan targetSelectors

  let
    planMap = InstallPlan.toMap elaboratedPlan
    targetIds = Map.keys targets

    sdistize (SpecificSourcePackage spkg) =
      SpecificSourcePackage spkg'
      where
        sdistPath = distSdistFile localDistDirLayout (packageId spkg)
        spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath }
    sdistize named = named

    local = sdistize <$> localPackages localBaseCtx

    gatherTargets :: UnitId -> TargetSelector
    gatherTargets targetId = TargetPackageNamed pkgName targetFilter
      where
        targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
        PackageIdentifier{..} = packageId targetUnit

    targets' = fmap gatherTargets targetIds

    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
    hackagePkgs = flip NamedPackage [] <$> hackageNames

    hackageTargets :: [TargetSelector]
    hackageTargets =
      flip TargetPackageNamed targetFilter <$> hackageNames

  createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)

  unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
      SpecificSourcePackage pkg -> packageToSdist verbosity
        (distProjectRootDirectory localDistDirLayout) TarGzArchive
        (distSdistFile localDistDirLayout (packageId pkg)) pkg
      NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName

  if null targets
    then return (hackagePkgs, hackageTargets)
    else return (local ++ hackagePkgs, targets' ++ hackageTargets)

-- | Partitions the target selectors into known local targets and hackage packages.
partitionToKnownTargetsAndHackagePackages
  :: Verbosity
  -> SourcePackageDb
  -> ElaboratedInstallPlan
  -> [TargetSelector]
  -> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
  let mTargets = resolveTargets
        selectPackageTargets
        selectComponentTarget
        elaboratedPlan
        (Just pkgDb)
        targetSelectors
  case mTargets of
    Right targets ->
      -- Everything is a local dependency.
      return (targets, [])
    Left errs     -> do
      -- Not everything is local.
      let
        (errs', hackageNames) = partitionEithers . flip fmap errs $ \case
          TargetAvailableInIndex name -> Right name
          err                         -> Left err

      -- report incorrect case for known package.
      for_ errs' $ \case
        TargetNotInProject hn ->
          case searchByName (packageIndex pkgDb) (unPackageName hn) of
            [] -> return ()
            xs -> die' verbosity . concat $
              [ "Unknown package \"", unPackageName hn, "\". "
              , "Did you mean any of the following?\n"
              , unlines (("- " ++) . unPackageName . fst <$> xs)
              ]
        _ -> return ()

      when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'

      let
        targetSelectors' = flip filter targetSelectors $ \case
          TargetComponentUnknown name _ _
            | name `elem` hackageNames -> False
          TargetPackageNamed name _
            | name `elem` hackageNames -> False
          _                            -> True

      -- This can't fail, because all of the errors are
      -- removed (or we've given up).
      targets <-
        either (reportBuildTargetProblems verbosity) return $
        resolveTargets
          selectPackageTargets
          selectComponentTarget
          elaboratedPlan
          Nothing
          targetSelectors'

      return (targets, hackageNames)



constructProjectBuildContext
  :: Verbosity
  -> ProjectBaseContext
     -- ^ The synthetic base context to use to produce the full build context.
  -> [TargetSelector]
  -> IO ProjectBuildContext
constructProjectBuildContext verbosity baseCtx targetSelectors = do
  runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
    -- Interpret the targets on the command line as build targets
    targets <- either (reportBuildTargetProblems verbosity) return $
      resolveTargets
        selectPackageTargets
        selectComponentTarget
        elaboratedPlan
        Nothing
        targetSelectors

    let prunedToTargetsElaboratedPlan =
          pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
    prunedElaboratedPlan <-
      if buildSettingOnlyDeps (buildSettings baseCtx)
      then either (reportCannotPruneDependencies verbosity) return $
           pruneInstallPlanToDependencies (Map.keysSet targets)
                                          prunedToTargetsElaboratedPlan
      else return prunedToTargetsElaboratedPlan

    return (prunedElaboratedPlan, targets)


-- | Install any built exe by symlinking/copying it
-- we don't use BuildOutcomes because we also need the component names
installExes
  :: Verbosity
  -> ProjectBaseContext
  -> ProjectBuildContext
  -> Platform
  -> Compiler
  -> ConfigFlags
  -> ClientInstallFlags
  -> IO ()
installExes verbosity baseCtx buildCtx platform compiler
            configFlags clientInstallFlags = do
  installPath <- defaultInstallPath
  let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx

      prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))
      suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))

      mkUnitBinDir :: UnitId -> FilePath
      mkUnitBinDir =
        InstallDirs.bindir .
        storePackageInstallDirs' storeDirLayout (compilerId compiler)

      mkExeName :: UnqualComponentName -> FilePath
      mkExeName exe = unUnqualComponentName exe <.> exeExtension platform

      mkFinalExeName :: UnqualComponentName -> FilePath
      mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform
      installdirUnknown =
        "installdir is not defined. Set it in your cabal config file "
        ++ "or use --installdir=<path>. Using default installdir: " ++ show installPath

  installdir <- fromFlagOrDefault
                (warn verbosity installdirUnknown >> pure installPath) $
                pure <$> cinstInstalldir clientInstallFlags
  createDirectoryIfMissingVerbose verbosity True installdir
  warnIfNoExes verbosity buildCtx

  installMethod <- flagElim defaultMethod return $
    cinstInstallMethod clientInstallFlags

  let
    doInstall = installUnitExes
                  verbosity
                  overwritePolicy
                  mkUnitBinDir mkExeName mkFinalExeName
                  installdir installMethod
    in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
  where
    overwritePolicy = fromFlagOrDefault NeverOverwrite $
                      cinstOverwritePolicy clientInstallFlags
    isWindows = buildOS == Windows

    -- This is in IO as we will make environment checks,
    -- to decide which method is best
    defaultMethod :: IO InstallMethod
    defaultMethod
      -- Try symlinking in temporary directory, if it works default to
      -- symlinking even on windows
      | isWindows = do
        symlinks <- trySymlink verbosity
        return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
      | otherwise = return InstallMethodSymlink

-- | Install any built library by adding it to the default ghc environment
installLibraries
  :: Verbosity
  -> ProjectBuildContext
  -> PI.PackageIndex InstalledPackageInfo
  -> Compiler
  -> PackageDBStack
  -> FilePath -- ^ Environment file
  -> [GhcEnvironmentFileEntry]
  -> IO ()
installLibraries verbosity buildCtx installedIndex compiler
                 packageDbs' envFile envEntries = do
  if supportsPkgEnvFiles $ getImplInfo compiler
    then do
      let validDb (SpecificPackageDB fp) = doesPathExist fp
          validDb _ = pure True
      -- if a user "installs" a global package and no existing cabal db exists, none will be created.
      -- this ensures we don't add the "phantom" path to the file.
      packageDbs <- filterM validDb packageDbs'
      let
        getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst))
                  . PI.lookupPackageName installedIndex
        globalLatest = concat (getLatest <$> globalPackages)
        globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest
        baseEntries =
          GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs
        pkgEntries = ordNub $
             globalEntries
          ++ envEntries
          ++ entriesForLibraryComponents (targetsMap buildCtx)
        contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
      createDirectoryIfMissing True (takeDirectory envFile)
      writeFileAtomic envFile (BS.pack contents')
    else
      warn verbosity $
          "The current compiler doesn't support safely installing libraries, "
        ++ "so only executables will be available. (Library installation is "
        ++ "supported on GHC 8.0+ only)"

-- See ticket #8894. This is safe to include any nonreinstallable boot pkg,
-- but the particular package users will always expect to be in scope without specific installation
-- is base, so that they can access prelude, regardles of if they specifically asked for it.
globalPackages :: [PackageName]
globalPackages = mkPackageName <$> [ "base" ]

warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes verbosity buildCtx =
  when noExes $
    warn verbosity $
    "\n" <>
    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>
    "@ WARNING: Installation might not be completed as desired! @\n" <>
    "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>
    "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <>
    "* You might have wanted to add them as dependencies to your package." <>
    " In this case add \"" <>
    intercalate ", " (showTargetSelector <$> selectors) <>
    "\" to the build-depends field(s) of your package's .cabal file.\n" <>
    "* You might have wanted to add them to a GHC environment. In this case" <>
    " use \"cabal install --lib " <>
    unwords (showTargetSelector <$> selectors) <> "\". " <>
    " The \"--lib\" flag is provisional: see" <>
    " https://github.com/haskell/cabal/issues/6481 for more information."
  where
    targets    = concat $ Map.elems $ targetsMap buildCtx
    components = fst <$> targets
    selectors  = concatMap (NE.toList . snd) targets
    noExes     = null $ catMaybes $ exeMaybe <$> components

    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
    exeMaybe _                                  = Nothing

-- | Return the package specifiers and non-global environment file entries.
getEnvSpecsAndNonGlobalEntries
  :: PI.InstalledPackageIndex
  -> [GhcEnvironmentFileEntry]
  -> Bool
  -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =
  if installLibs
  then (envSpecs, envEntries')
  else ([], envEntries')
  where
    (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries

environmentFileToSpecifiers
  :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]
  -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers ipi = foldMap $ \case
    (GhcEnvFilePackageId unitId)
        | Just InstalledPackageInfo
          { sourcePackageId = PackageIdentifier{..}, installedUnitId }
          <- PI.lookupUnitId ipi unitId
        , let pkgSpec = NamedPackage pkgName
                        [PackagePropertyVersion (thisVersion pkgVersion)]
        -> ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)])
    _ -> ([], [])


-- | Disables tests and benchmarks if they weren't explicitly enabled.
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault configFlags =
  configFlags { configTests = Flag False <> configTests configFlags
              , configBenchmarks = Flag False <> configBenchmarks configFlags }

-- | Symlink/copy every exe from a package from the store to a given location
installUnitExes
  :: Verbosity
  -> OverwritePolicy -- ^ Whether to overwrite existing files
  -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
                          -- ^ store directory
  -> (UnqualComponentName -> FilePath) -- ^ A function to get an
                                       -- ^ exe's filename
  -> (UnqualComponentName -> FilePath) -- ^ A function to get an
                                       -- ^ exe's final possibly
                                       -- ^ different to the name in the store.
  -> FilePath
  -> InstallMethod
  -> ( UnitId
     , [(ComponentTarget, NonEmpty TargetSelector)] )
  -> IO ()
installUnitExes verbosity overwritePolicy
                mkSourceBinDir mkExeName mkFinalExeName
                installdir installMethod
                (unit, components) =
  traverse_ installAndWarn exes
  where
    exes = catMaybes $ (exeMaybe . fst) <$> components
    exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
    exeMaybe _ = Nothing
    installAndWarn exe = do
      success <- installBuiltExe
                   verbosity overwritePolicy
                   (mkSourceBinDir unit) (mkExeName exe)
                   (mkFinalExeName exe)
                   installdir installMethod
      let errorMessage = case overwritePolicy of
            NeverOverwrite ->
              "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "
              <> "Use --overwrite-policy=always to overwrite."
            -- This shouldn't even be possible, but we keep it in case
            -- symlinking/copying logic changes
            _ ->
              case installMethod of
                InstallMethodSymlink -> "Symlinking"
                InstallMethodCopy    ->
                  "Copying" <> " '" <> prettyShow exe <> "' failed."
      unless success $ die' verbosity errorMessage

-- | Install a specific exe.
installBuiltExe
  :: Verbosity -> OverwritePolicy
  -> FilePath -- ^ The directory where the built exe is located
  -> FilePath -- ^ The exe's filename
  -> FilePath -- ^ The exe's filename in the public install directory
  -> FilePath -- ^ the directory where it should be installed
  -> InstallMethod
  -> IO Bool -- ^ Whether the installation was successful
installBuiltExe verbosity overwritePolicy
                sourceDir exeName finalExeName
                installdir InstallMethodSymlink = do
  notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"
  symlinkBinary
    overwritePolicy
    installdir
    sourceDir
    finalExeName
    exeName
  where
    destination = installdir </> finalExeName
installBuiltExe verbosity overwritePolicy
                sourceDir exeName finalExeName
                installdir InstallMethodCopy = do
  notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"
  exists <- doesPathExist destination
  case (exists, overwritePolicy) of
    (True , NeverOverwrite ) -> pure False
    (True , AlwaysOverwrite) -> overwrite
    (True , PromptOverwrite) -> maybeOverwrite
    (False, _              ) -> copy
  where
    source      = sourceDir </> exeName
    destination = installdir </> finalExeName
    remove = do
      isDir <- doesDirectoryExist destination
      if isDir
      then removeDirectory destination
      else removeFile      destination
    copy = copyFile source destination >> pure True
    overwrite :: IO Bool
    overwrite = remove >> copy
    maybeOverwrite :: IO Bool
    maybeOverwrite
      = promptRun
        "Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
        overwrite

-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
  where
    hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool
    hasLib (ComponentTarget (CLibName _) _, _) = True
    hasLib _                                   = False

    go :: UnitId
       -> [(ComponentTarget, NonEmpty TargetSelector)]
       -> [GhcEnvironmentFileEntry]
    go unitId targets
      | any hasLib targets = [GhcEnvFilePackageId unitId]
      | otherwise          = []


-- | Gets the file path to the request environment file.
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile clientInstallFlags platform compilerVersion = do
  appDir <- getGhcAppDir
  case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of
    Just spec
      -- Is spec a bare word without any "pathy" content, then it refers to
      -- a named global environment.
      | takeBaseName spec == spec ->
          return (getGlobalEnv appDir platform compilerVersion spec)
      | otherwise                 -> do
        spec' <- makeAbsolute spec
        isDir <- doesDirectoryExist spec'
        if isDir
          -- If spec is a directory, then make an ambient environment inside
          -- that directory.
          then return (getLocalEnv spec' platform compilerVersion)
          -- Otherwise, treat it like a literal file path.
          else return spec'
    Nothing                       ->
      return (getGlobalEnv appDir platform compilerVersion "default")

-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the
--   environment being operated on.
getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do
  envFileExists <- doesFileExist envFile
  filterEnvEntries <$> if
    (compilerFlavor == GHC || compilerFlavor == GHCJS)
      && supportsPkgEnvFiles && envFileExists
    then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
      warn verbosity ("The environment file " ++ envFile ++
        " is unparsable. Libraries cannot be installed.") >> return []
    else return []
  where
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries = filter $ \case
      GhcEnvFilePackageId _ -> True
      _                     -> False

-- | Constructs the path to the global GHC environment file.
--
-- TODO(m-renaud): Create PkgEnvName newtype wrapper.
getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath
getGlobalEnv appDir platform compilerVersion name =
  appDir </> ghcPlatformAndVersionString platform compilerVersion
  </> "environments" </> name

-- | Constructs the path to a local GHC environment file.
getLocalEnv :: FilePath -> Platform -> Version -> FilePath
getLocalEnv dir platform compilerVersion  =
  dir </>
  ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion

getPackageDbStack
  :: CompilerId
  -> Flag FilePath
  -> Flag FilePath
  -> IO PackageDBStack
getPackageDbStack compilerId storeDirFlag logsDirFlag = do
  mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
  let
    mlogsDir    = flagToMaybe logsDirFlag
  cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId

-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
--
selectPackageTargets
  :: TargetSelector
  -> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets targetSelector targets

    -- If there are any buildable targets then we select those
  | not (null targetsBuildable)
  = Right targetsBuildable

    -- If there are targets but none are buildable then we report those
  | not (null targets)
  = Left (TargetProblemNoneEnabled targetSelector targets')

    -- If there are no targets at all then we report that
  | otherwise
  = Left (TargetProblemNoTargets targetSelector)
  where
    targets'         = forgetTargetsDetail targets
    targetsBuildable = selectBuildableTargetsWith
                         (buildable targetSelector)
                         targets

    -- When there's a target filter like "pkg:tests" then we do select tests,
    -- but if it's just a target like "pkg" then we don't build tests unless
    -- they are requested by default (i.e. by using --enable-tests)
    buildable (TargetPackage _ _  Nothing) TargetNotRequestedByDefault = False
    buildable (TargetAllPackages  Nothing) TargetNotRequestedByDefault = False
    buildable _ _ = True

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @build@ command we just need the basic checks on being buildable etc.
--
selectComponentTarget
  :: SubComponentTarget
  -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget = selectComponentTargetBasic

reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems

reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies verbosity =
    die' verbosity . renderCannotPruneDependencies