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

  , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ClientInstallFlags)]
commandOptions      = \ShowOrParseArgs
x -> (OptionField (NixStyleFlags ClientInstallFlags) -> Bool)
-> [OptionField (NixStyleFlags ClientInstallFlags)]
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a. (a -> Bool) -> [a] -> [a]
filter OptionField (NixStyleFlags ClientInstallFlags) -> Bool
forall {a}. OptionField a -> Bool
notInstallDirOpt ([OptionField (NixStyleFlags ClientInstallFlags)]
 -> [OptionField (NixStyleFlags ClientInstallFlags)])
-> [OptionField (NixStyleFlags ClientInstallFlags)]
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a b. (a -> b) -> a -> b
$ (ShowOrParseArgs -> [OptionField ClientInstallFlags])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions ShowOrParseArgs
x
  , commandDefaultFlags :: NixStyleFlags ClientInstallFlags
commandDefaultFlags = ClientInstallFlags -> NixStyleFlags ClientInstallFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ClientInstallFlags
defaultClientInstallFlags
  }
 where
  -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.
  notInstallDirOpt :: OptionField a -> Bool
notInstallDirOpt OptionField a
x = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ OptionField a -> FilePath
forall a. OptionField a -> FilePath
optionName OptionField a
x FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
installDirOptNames
  installDirOptNames :: [FilePath]
installDirOptNames = (OptionField (InstallDirs (Flag PathTemplate)) -> FilePath)
-> [OptionField (InstallDirs (Flag PathTemplate))] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map OptionField (InstallDirs (Flag PathTemplate)) -> FilePath
forall a. OptionField a -> FilePath
optionName [OptionField (InstallDirs (Flag PathTemplate))]
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 :: NixStyleFlags ClientInstallFlags
-> [FilePath] -> GlobalFlags -> IO ()
installAction flags :: NixStyleFlags ClientInstallFlags
flags@NixStyleFlags { extraFlags :: forall a. NixStyleFlags a -> a
extraFlags = ClientInstallFlags
clientInstallFlags', HaddockFlags
BenchmarkFlags
ConfigFlags
TestFlags
ProjectFlags
InstallFlags
ConfigExFlags
configFlags :: ConfigFlags
configExFlags :: ConfigExFlags
installFlags :: InstallFlags
haddockFlags :: HaddockFlags
testFlags :: TestFlags
benchmarkFlags :: BenchmarkFlags
projectFlags :: ProjectFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
.. } [FilePath]
targetStrings GlobalFlags
globalFlags = do
  -- Ensure there were no invalid configuration options specified.
  Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
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
clientInstallFlags <- Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
clientInstallFlags'

  let
    installLibs :: Bool
installLibs    = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientInstallFlags -> Flag Bool
cinstInstallLibs ClientInstallFlags
clientInstallFlags)
    targetFilter :: Maybe ComponentKind
targetFilter   = if Bool
installLibs then ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
LibKind else ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
ExeKind
    targetStrings' :: [FilePath]
targetStrings' = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings then [FilePath
"."] else [FilePath]
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 :: IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
withProject = do
      let reducedVerbosity :: Verbosity
reducedVerbosity = Verbosity -> Verbosity
lessVerbose Verbosity
verbosity

      -- First, we need to learn about what's available to be installed.
      ProjectBaseContext
localBaseCtx <-
        Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
reducedVerbosity ProjectConfig
cliConfig CurrentCommand
InstallCommand
      let localDistDirLayout :: DistDirLayout
localDistDirLayout = ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
localBaseCtx
      SourcePackageDb
pkgDb <- Verbosity
-> BuildTimeSettings
-> (RepoContext -> IO SourcePackageDb)
-> IO SourcePackageDb
forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext Verbosity
reducedVerbosity
               (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
localBaseCtx) (Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity)

      let
        ([FilePath]
targetStrings'', [PackageId]
packageIds) =
          [Either FilePath PackageId] -> ([FilePath], [PackageId])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either FilePath PackageId] -> ([FilePath], [PackageId]))
-> ((FilePath -> Either FilePath PackageId)
    -> [Either FilePath PackageId])
-> (FilePath -> Either FilePath PackageId)
-> ([FilePath], [PackageId])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ((FilePath -> Either FilePath PackageId)
 -> [FilePath] -> [Either FilePath PackageId])
-> [FilePath]
-> (FilePath -> Either FilePath PackageId)
-> [Either FilePath PackageId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> Either FilePath PackageId)
-> [FilePath] -> [Either FilePath PackageId]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath]
targetStrings' ((FilePath -> Either FilePath PackageId)
 -> ([FilePath], [PackageId]))
-> (FilePath -> Either FilePath PackageId)
-> ([FilePath], [PackageId])
forall a b. (a -> b) -> a -> b
$
          \FilePath
str -> case FilePath -> Maybe PackageId
forall a. Parsec a => FilePath -> Maybe a
simpleParsec FilePath
str of
            Just (PackageId
pkgId :: PackageId)
              | PackageId -> Version
pkgVersion PackageId
pkgId Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
nullVersion -> PackageId -> Either FilePath PackageId
forall a b. b -> Either a b
Right PackageId
pkgId
            Maybe PackageId
_                                   -> FilePath -> Either FilePath PackageId
forall a b. a -> Either a b
Left FilePath
str
        packageSpecifiers :: [PackageSpecifier pkg]
packageSpecifiers =
          ((PackageId -> PackageSpecifier pkg)
 -> [PackageId] -> [PackageSpecifier pkg])
-> [PackageId]
-> (PackageId -> PackageSpecifier pkg)
-> [PackageSpecifier pkg]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (PackageId -> PackageSpecifier pkg)
-> [PackageId] -> [PackageSpecifier pkg]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PackageId]
packageIds ((PackageId -> PackageSpecifier pkg) -> [PackageSpecifier pkg])
-> (PackageId -> PackageSpecifier pkg) -> [PackageSpecifier pkg]
forall a b. (a -> b) -> a -> b
$ \case
          PackageIdentifier{PackageName
Version
pkgVersion :: PackageId -> Version
pkgName :: PackageName
pkgVersion :: Version
pkgName :: PackageId -> PackageName
..}
            | Version
pkgVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
nullVersion -> PackageName -> [PackageProperty] -> PackageSpecifier pkg
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName []
            | Bool
otherwise                 -> PackageName -> [PackageProperty] -> PackageSpecifier pkg
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName
                                           [VersionRange -> PackageProperty
PackagePropertyVersion
                                            (Version -> VersionRange
thisVersion Version
pkgVersion)]
        packageTargets :: [TargetSelector]
packageTargets =
          (PackageName -> Maybe ComponentKind -> TargetSelector)
-> Maybe ComponentKind -> PackageName -> TargetSelector
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed Maybe ComponentKind
targetFilter (PackageName -> TargetSelector)
-> (PackageId -> PackageName) -> PackageId -> TargetSelector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
pkgName (PackageId -> TargetSelector) -> [PackageId] -> [TargetSelector]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageId]
packageIds

      if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings'' -- if every selector is already resolved as a packageid, return without further parsing.
        then ([PackageSpecifier UnresolvedSourcePackage], [URI],
 [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers, [], [TargetSelector]
packageTargets, ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
localBaseCtx)
        else do
          [TargetSelector]
targetSelectors <-
            ([TargetSelectorProblem] -> IO [TargetSelector])
-> ([TargetSelector] -> IO [TargetSelector])
-> Either [TargetSelectorProblem] [TargetSelector]
-> IO [TargetSelector]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetSelectorProblem] -> IO [TargetSelector]
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) [TargetSelector] -> IO [TargetSelector]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Either [TargetSelectorProblem] [TargetSelector]
 -> IO [TargetSelector])
-> IO (Either [TargetSelectorProblem] [TargetSelector])
-> IO [TargetSelector]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [PackageSpecifier UnresolvedSourcePackage]
-> Maybe ComponentKind
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx)
                                    Maybe ComponentKind
forall a. Maybe a
Nothing [FilePath]
targetStrings''

          ([PackageSpecifier UnresolvedSourcePackage]
specs, [TargetSelector]
selectors) <-
            Verbosity
-> Verbosity
-> SourcePackageDb
-> [TargetSelector]
-> DistDirLayout
-> ProjectBaseContext
-> Maybe ComponentKind
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors
              Verbosity
verbosity Verbosity
reducedVerbosity SourcePackageDb
pkgDb [TargetSelector]
targetSelectors DistDirLayout
localDistDirLayout ProjectBaseContext
localBaseCtx Maybe ComponentKind
targetFilter

          ([PackageSpecifier UnresolvedSourcePackage], [URI],
 [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( [PackageSpecifier UnresolvedSourcePackage]
specs [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers
                 , []
                 , [TargetSelector]
selectors [TargetSelector] -> [TargetSelector] -> [TargetSelector]
forall a. [a] -> [a] -> [a]
++ [TargetSelector]
packageTargets
                 , ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
localBaseCtx )

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

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

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

        mlogsDir :: Maybe FilePath
mlogsDir = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigLogsDir
        mstoreDir :: Maybe FilePath
mstoreDir = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigStoreDir
      CabalDirLayout
cabalDirLayout <- Maybe FilePath -> Maybe FilePath -> IO CabalDirLayout
mkCabalDirLayout Maybe FilePath
mstoreDir Maybe FilePath
mlogsDir

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

      SourcePackageDb { PackageIndex UnresolvedSourcePackage
packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex :: SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex } <- Verbosity
-> BuildTimeSettings
-> (RepoContext -> IO SourcePackageDb)
-> IO SourcePackageDb
forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext
                                            Verbosity
verbosity BuildTimeSettings
buildSettings
                                            (Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity)

      [PackageName] -> (PackageName -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((WithoutProjectTargetSelector -> [PackageName])
-> [WithoutProjectTargetSelector] -> [PackageName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WithoutProjectTargetSelector -> [PackageName]
woPackageNames [WithoutProjectTargetSelector]
tss) ((PackageName -> IO ()) -> IO ())
-> (PackageName -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PackageName
name -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([UnresolvedSourcePackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (PackageIndex UnresolvedSourcePackage
-> PackageName -> [UnresolvedSourcePackage]
forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
lookupPackageName PackageIndex UnresolvedSourcePackage
packageIndex PackageName
name)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          let xs :: [(PackageName, [UnresolvedSourcePackage])]
xs = PackageIndex UnresolvedSourcePackage
-> FilePath -> [(PackageName, [UnresolvedSourcePackage])]
forall pkg. PackageIndex pkg -> FilePath -> [(PackageName, [pkg])]
searchByName PackageIndex UnresolvedSourcePackage
packageIndex (PackageName -> FilePath
unPackageName PackageName
name)
          let emptyIf :: Bool -> [a] -> [a]
emptyIf Bool
True  [a]
_  = []
              emptyIf Bool
False [a]
zs = [a]
zs
          Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
            [ FilePath
"Unknown package \"", PackageName -> FilePath
unPackageName PackageName
name, FilePath
"\". "
            ] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ Bool -> [FilePath] -> [FilePath]
forall {a}. Bool -> [a] -> [a]
emptyIf ([(PackageName, [UnresolvedSourcePackage])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, [UnresolvedSourcePackage])]
xs)
            [ FilePath
"Did you mean any of the following?\n"
            , [FilePath] -> FilePath
unlines ((FilePath
"- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> ((PackageName, [UnresolvedSourcePackage]) -> FilePath)
-> (PackageName, [UnresolvedSourcePackage])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> ((PackageName, [UnresolvedSourcePackage]) -> PackageName)
-> (PackageName, [UnresolvedSourcePackage])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, [UnresolvedSourcePackage]) -> PackageName
forall a b. (a, b) -> a
fst ((PackageName, [UnresolvedSourcePackage]) -> FilePath)
-> [(PackageName, [UnresolvedSourcePackage])] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
            ]

      let
        ([URI]
uris, [PackageSpecifier pkg]
packageSpecifiers) = [Either URI (PackageSpecifier pkg)]
-> ([URI], [PackageSpecifier pkg])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either URI (PackageSpecifier pkg)]
 -> ([URI], [PackageSpecifier pkg]))
-> [Either URI (PackageSpecifier pkg)]
-> ([URI], [PackageSpecifier pkg])
forall a b. (a -> b) -> a -> b
$ (WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg))
-> [WithoutProjectTargetSelector]
-> [Either URI (PackageSpecifier pkg)]
forall a b. (a -> b) -> [a] -> [b]
map WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
forall pkg.
WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
woPackageSpecifiers [WithoutProjectTargetSelector]
tss
        packageTargets :: [TargetSelector]
packageTargets            = (WithoutProjectTargetSelector -> TargetSelector)
-> [WithoutProjectTargetSelector] -> [TargetSelector]
forall a b. (a -> b) -> [a] -> [b]
map WithoutProjectTargetSelector -> TargetSelector
woPackageTargets [WithoutProjectTargetSelector]
tss

      ([PackageSpecifier UnresolvedSourcePackage], [URI],
 [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers, [URI]
uris, [TargetSelector]
packageTargets, ProjectConfig
projectConfig)

  ([PackageSpecifier UnresolvedSourcePackage]
specs, [URI]
uris, [TargetSelector]
targetSelectors, ProjectConfig
config) <-
     Verbosity
-> Flag Bool
-> Flag FilePath
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
-> (ProjectConfig
    -> IO
         ([PackageSpecifier UnresolvedSourcePackage], [URI],
          [TargetSelector], ProjectConfig))
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a.
Verbosity
-> Flag Bool
-> Flag FilePath
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
ignoreProject Flag FilePath
globalConfigFlag IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
withProject ProjectConfig
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
withoutProject

  let
    ProjectConfig {
      projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly = ProjectConfigBuildOnly {
        Flag FilePath
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigLogsDir :: Flag FilePath
projectConfigLogsDir
      },
      projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared = ProjectConfigShared {
        Flag CompilerFlavor
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigHcFlavor,
        Flag FilePath
projectConfigHcPath :: Flag FilePath
projectConfigHcPath :: ProjectConfigShared -> Flag FilePath
projectConfigHcPath,
        Flag FilePath
projectConfigHcPkg :: Flag FilePath
projectConfigHcPkg :: ProjectConfigShared -> Flag FilePath
projectConfigHcPkg,
        Flag FilePath
projectConfigStoreDir :: ProjectConfigShared -> Flag FilePath
projectConfigStoreDir :: Flag FilePath
projectConfigStoreDir,
        NubList FilePath
projectConfigProgPathExtra :: NubList FilePath
projectConfigProgPathExtra :: ProjectConfigShared -> NubList FilePath
projectConfigProgPathExtra
      },
      projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages = PackageConfig {
        MapLast FilePath FilePath
packageConfigProgramPaths :: MapLast FilePath FilePath
packageConfigProgramPaths :: PackageConfig -> MapLast FilePath FilePath
packageConfigProgramPaths,
        MapMappend FilePath [FilePath]
packageConfigProgramArgs :: MapMappend FilePath [FilePath]
packageConfigProgramArgs :: PackageConfig -> MapMappend FilePath [FilePath]
packageConfigProgramArgs,
        NubList FilePath
packageConfigProgramPathExtra :: NubList FilePath
packageConfigProgramPathExtra :: PackageConfig -> NubList FilePath
packageConfigProgramPathExtra
      }
    } = ProjectConfig
config

    hcFlavor :: Maybe CompilerFlavor
hcFlavor = Flag CompilerFlavor -> Maybe CompilerFlavor
forall a. Flag a -> Maybe a
flagToMaybe Flag CompilerFlavor
projectConfigHcFlavor
    hcPath :: Maybe FilePath
hcPath   = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHcPath
    hcPkg :: Maybe FilePath
hcPkg    = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHcPkg

  ProgramDb
configProgDb <- Verbosity -> [FilePath] -> ProgramDb -> IO ProgramDb
appendProgramSearchPath Verbosity
verbosity ((NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList NubList FilePath
packageConfigProgramPathExtra) [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList NubList FilePath
projectConfigProgPathExtra)) ProgramDb
defaultProgramDb
  let
    -- ProgramDb with directly user specified paths
    preProgDb :: ProgramDb
preProgDb =
      [(FilePath, FilePath)] -> ProgramDb -> ProgramDb
userSpecifyPaths (Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toList (MapLast FilePath FilePath -> Map FilePath FilePath
forall k v. MapLast k v -> Map k v
getMapLast MapLast FilePath FilePath
packageConfigProgramPaths))
        (ProgramDb -> ProgramDb)
-> (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, [FilePath])] -> ProgramDb -> ProgramDb
userSpecifyArgss (Map FilePath [FilePath] -> [(FilePath, [FilePath])]
forall k a. Map k a -> [(k, a)]
Map.toList (MapMappend FilePath [FilePath] -> Map FilePath [FilePath]
forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend FilePath [FilePath]
packageConfigProgramArgs))
        (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$ ProgramDb
configProgDb

  -- progDb is a program database with compiler tools configured properly
  (compiler :: Compiler
compiler@Compiler { compilerId :: Compiler -> CompilerId
compilerId =
    compilerId :: CompilerId
compilerId@(CompilerId CompilerFlavor
compilerFlavor Version
compilerVersion) }, Platform
platform, ProgramDb
progDb) <-
      Maybe CompilerFlavor
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> Verbosity
-> IO (Compiler, Platform, ProgramDb)
configCompilerEx Maybe CompilerFlavor
hcFlavor Maybe FilePath
hcPath Maybe FilePath
hcPkg ProgramDb
preProgDb Verbosity
verbosity

  let
    GhcImplInfo{ Bool
supportsPkgEnvFiles :: Bool
supportsPkgEnvFiles :: GhcImplInfo -> Bool
supportsPkgEnvFiles } = Compiler -> GhcImplInfo
getImplInfo Compiler
compiler

  FilePath
envFile <- ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion
  [GhcEnvironmentFileEntry]
existingEnvEntries <-
    Verbosity
-> CompilerFlavor
-> Bool
-> FilePath
-> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile
  PackageDBStack
packageDbs <- CompilerId -> Flag FilePath -> Flag FilePath -> IO PackageDBStack
getPackageDbStack CompilerId
compilerId Flag FilePath
projectConfigStoreDir Flag FilePath
projectConfigLogsDir
  InstalledPackageIndex
installedIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
compiler PackageDBStack
packageDbs ProgramDb
progDb

  let
    ([PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries) =
      InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> Bool
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> Bool
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry]
existingEnvEntries Bool
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.
  FilePath
globalTmp <- IO FilePath
getTemporaryDirectory

  Verbosity -> FilePath -> FilePath -> (FilePath -> IO ()) -> IO ()
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
globalTmp FilePath
"cabal-install." ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
    DistDirLayout
distDirLayout <- Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity ProjectConfig
config FilePath
tmpDir

    [PackageSpecifier UnresolvedSourcePackage]
uriSpecs <- FilePath
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
-> IO [PackageSpecifier UnresolvedSourcePackage]
forall a. FilePath -> Rebuild a -> IO a
runRebuild FilePath
tmpDir (Rebuild [PackageSpecifier UnresolvedSourcePackage]
 -> IO [PackageSpecifier UnresolvedSourcePackage])
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
-> IO [PackageSpecifier UnresolvedSourcePackage]
forall a b. (a -> b) -> a -> b
$ Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> [ProjectPackageLocation]
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
fetchAndReadSourcePackages
      Verbosity
verbosity
      DistDirLayout
distDirLayout
      (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
config)
      (ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
config)
      [ URI -> ProjectPackageLocation
ProjectPackageRemoteTarball URI
uri | URI
uri <- [URI]
uris ]

    -- check for targets already in env
    let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
        getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName (NamedPackage PackageName
pn [PackageProperty]
_) = PackageName
pn
        getPackageName (SpecificSourcePackage (SourcePackage PackageId
pkgId GenericPackageDescription
_ UnresolvedPkgLoc
_ PackageDescriptionOverride
_)) = PackageId -> PackageName
pkgName PackageId
pkgId
        targetNames :: Set PackageName
targetNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
S.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName ([PackageSpecifier UnresolvedSourcePackage]
specs [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
        envNames :: Set PackageName
envNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
S.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName [PackageSpecifier UnresolvedSourcePackage]
forall {pkg}. [PackageSpecifier pkg]
envSpecs
        forceInstall :: Bool
forceInstall = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags
        nameIntersection :: Set PackageName
nameIntersection = Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set PackageName
targetNames Set PackageName
envNames

    -- we check for intersections in targets with the existing env
    ([PackageSpecifier UnresolvedSourcePackage]
envSpecs', [GhcEnvironmentFileEntry]
nonGlobalEnvEntries') <- if Set PackageName -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
nameIntersection
      then ([PackageSpecifier UnresolvedSourcePackage],
 [GhcEnvironmentFileEntry])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageSpecifier UnresolvedSourcePackage]
forall {pkg}. [PackageSpecifier pkg]
envSpecs, ((PackageName, GhcEnvironmentFileEntry) -> GhcEnvironmentFileEntry)
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, GhcEnvironmentFileEntry) -> GhcEnvironmentFileEntry
forall a b. (a, b) -> b
snd [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries)
      else if Bool
forceInstall
             then let es :: [PackageSpecifier UnresolvedSourcePackage]
es = (PackageSpecifier UnresolvedSourcePackage -> Bool)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageSpecifier UnresolvedSourcePackage
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName PackageSpecifier UnresolvedSourcePackage
e PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) [PackageSpecifier UnresolvedSourcePackage]
forall {pkg}. [PackageSpecifier pkg]
envSpecs
                      nge :: [GhcEnvironmentFileEntry]
nge = ((PackageName, GhcEnvironmentFileEntry) -> GhcEnvironmentFileEntry)
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, GhcEnvironmentFileEntry) -> GhcEnvironmentFileEntry
forall a b. (a, b) -> b
snd ([(PackageName, GhcEnvironmentFileEntry)]
 -> [GhcEnvironmentFileEntry])
-> ([(PackageName, GhcEnvironmentFileEntry)]
    -> [(PackageName, GhcEnvironmentFileEntry)])
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, GhcEnvironmentFileEntry) -> Bool)
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [(PackageName, GhcEnvironmentFileEntry)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, GhcEnvironmentFileEntry)
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PackageName, GhcEnvironmentFileEntry) -> PackageName
forall a b. (a, b) -> a
fst (PackageName, GhcEnvironmentFileEntry)
e PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) ([(PackageName, GhcEnvironmentFileEntry)]
 -> [GhcEnvironmentFileEntry])
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$ [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries
                  in ([PackageSpecifier UnresolvedSourcePackage],
 [GhcEnvironmentFileEntry])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageSpecifier UnresolvedSourcePackage]
es, [GhcEnvironmentFileEntry]
nge)
             else Verbosity
-> FilePath
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry])
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath
 -> IO
      ([PackageSpecifier UnresolvedSourcePackage],
       [GhcEnvironmentFileEntry]))
-> FilePath
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry])
forall a b. (a -> b) -> a -> b
$ FilePath
"Packages requested to install already exist in environment file at " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
envFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " ((PackageName -> FilePath) -> [PackageName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ([PackageName] -> [FilePath]) -> [PackageName] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
S.toList Set PackageName
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 :: [(PackageName, [InstalledPackageInfo])]
installedPacks = InstalledPackageIndex -> [(PackageName, [InstalledPackageInfo])]
forall a. PackageIndex a -> [(PackageName, [a])]
PI.allPackagesByName InstalledPackageIndex
installedIndex
        newEnvNames :: Set PackageName
newEnvNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
S.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName [PackageSpecifier UnresolvedSourcePackage]
envSpecs'
        installedIndex' :: InstalledPackageIndex
installedIndex' = [InstalledPackageInfo] -> InstalledPackageIndex
PI.fromList ([InstalledPackageInfo] -> InstalledPackageIndex)
-> ([(PackageName, [InstalledPackageInfo])]
    -> [InstalledPackageInfo])
-> [(PackageName, [InstalledPackageInfo])]
-> InstalledPackageIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(PackageName, [InstalledPackageInfo])]
-> [InstalledPackageInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd ([(PackageName, [InstalledPackageInfo])] -> [InstalledPackageInfo])
-> ([(PackageName, [InstalledPackageInfo])]
    -> [(PackageName, [InstalledPackageInfo])])
-> [(PackageName, [InstalledPackageInfo])]
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo]) -> Bool)
-> [(PackageName, [InstalledPackageInfo])]
-> [(PackageName, [InstalledPackageInfo])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, [InstalledPackageInfo])
p -> (PackageName, [InstalledPackageInfo]) -> PackageName
forall a b. (a, b) -> a
fst (PackageName, [InstalledPackageInfo])
p PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
newEnvNames) ([(PackageName, [InstalledPackageInfo])] -> InstalledPackageIndex)
-> [(PackageName, [InstalledPackageInfo])] -> InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ [(PackageName, [InstalledPackageInfo])]
installedPacks

    ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig
-> DistDirLayout
-> [PackageSpecifier UnresolvedSourcePackage]
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext
                 Verbosity
verbosity
                 ProjectConfig
config
                 DistDirLayout
distDirLayout
                 ([PackageSpecifier UnresolvedSourcePackage]
envSpecs' [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
specs [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
                 CurrentCommand
InstallCommand

    ProjectBuildContext
buildCtx <- Verbosity
-> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext
constructProjectBuildContext Verbosity
verbosity (ProjectBaseContext
baseCtx {installedPackages = Just installedIndex'}) [TargetSelector]
targetSelectors

    Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx

    BuildOutcomes
buildOutcomes <- Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx
    Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx BuildOutcomes
buildOutcomes

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

    -- Then, install!
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      if Bool
installLibs
      then Verbosity
-> ProjectBuildContext
-> InstalledPackageIndex
-> Compiler
-> PackageDBStack
-> FilePath
-> [GhcEnvironmentFileEntry]
-> IO ()
installLibraries Verbosity
verbosity
           ProjectBuildContext
buildCtx InstalledPackageIndex
installedIndex Compiler
compiler PackageDBStack
packageDbs FilePath
envFile [GhcEnvironmentFileEntry]
nonGlobalEnvEntries'
      else Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes Verbosity
verbosity
           ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx Platform
platform Compiler
compiler ConfigFlags
configFlags ClientInstallFlags
clientInstallFlags
  where
    configFlags' :: ConfigFlags
configFlags' = ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault ConfigFlags
configFlags
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags')
    ignoreProject :: Flag Bool
ignoreProject = ProjectFlags -> Flag Bool
flagIgnoreProject ProjectFlags
projectFlags
    baseCliConfig :: ProjectConfig
baseCliConfig = GlobalFlags
-> NixStyleFlags ClientInstallFlags
-> ClientInstallFlags
-> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
                        GlobalFlags
globalFlags
                        NixStyleFlags ClientInstallFlags
flags { configFlags = configFlags' }
                        ClientInstallFlags
clientInstallFlags'
    cliConfig :: ProjectConfig
cliConfig = ProjectConfig -> [FilePath] -> ProjectConfig
addLocalConfigToTargets ProjectConfig
baseCliConfig [FilePath]
targetStrings
    globalConfigFlag :: Flag FilePath
globalConfigFlag = ProjectConfigShared -> Flag FilePath
projectConfigConfigFile (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)

-- | Treat all direct targets of install command as local packages: #8637
addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig
addLocalConfigToTargets :: ProjectConfig -> [FilePath] -> ProjectConfig
addLocalConfigToTargets ProjectConfig
config [FilePath]
targetStrings
    = ProjectConfig
config {
        projectConfigSpecificPackage = projectConfigSpecificPackage config
                                       <> MapMappend (Map.fromList targetPackageConfigs)
    }
  where
    localConfig :: PackageConfig
localConfig = ProjectConfig -> PackageConfig
projectConfigLocalPackages ProjectConfig
config
    targetPackageConfigs :: [(PackageName, PackageConfig)]
targetPackageConfigs = (FilePath -> (PackageName, PackageConfig))
-> [FilePath] -> [(PackageName, PackageConfig)]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> (FilePath -> PackageName
mkPackageName FilePath
x, PackageConfig
localConfig)) [FilePath]
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 -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
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.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"--enable-tests was specified, but tests can't "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"be enabled in a remote package"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"--enable-benchmarks was specified, but benchmarks can't "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"be enabled in a remote package"

getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags :: Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
existingClientInstallFlags = do
  let configFileFlag :: Flag FilePath
configFileFlag = GlobalFlags -> Flag FilePath
globalConfigFile GlobalFlags
globalFlags
  SavedConfig
savedConfig <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
  ClientInstallFlags -> IO ClientInstallFlags
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientInstallFlags -> IO ClientInstallFlags)
-> ClientInstallFlags -> IO ClientInstallFlags
forall a b. (a -> b) -> a -> b
$ SavedConfig -> ClientInstallFlags
savedClientInstallFlags SavedConfig
savedConfig ClientInstallFlags -> ClientInstallFlags -> ClientInstallFlags
forall a. Monoid a => a -> a -> a
`mappend` ClientInstallFlags
existingClientInstallFlags


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

  let
    planMap :: Map
  UnitId
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
planMap = ElaboratedInstallPlan
-> Map
     UnitId
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
InstallPlan.toMap ElaboratedInstallPlan
elaboratedPlan
    targetIds :: [UnitId]
targetIds = TargetsMap -> [UnitId]
forall k a. Map k a -> [k]
Map.keys TargetsMap
targets

    sdistize :: PackageSpecifier (SourcePackage (PackageLocation local))
-> PackageSpecifier (SourcePackage (PackageLocation local))
sdistize (SpecificSourcePackage SourcePackage (PackageLocation local)
spkg) =
      SourcePackage (PackageLocation local)
-> PackageSpecifier (SourcePackage (PackageLocation local))
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage SourcePackage (PackageLocation local)
forall {local}. SourcePackage (PackageLocation local)
spkg'
      where
        sdistPath :: FilePath
sdistPath = DistDirLayout -> PackageId -> FilePath
distSdistFile DistDirLayout
localDistDirLayout (SourcePackage (PackageLocation local) -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId SourcePackage (PackageLocation local)
spkg)
        spkg' :: SourcePackage (PackageLocation local)
spkg' = SourcePackage (PackageLocation local)
spkg { srcpkgSource = LocalTarballPackage sdistPath }
    sdistize PackageSpecifier (SourcePackage (PackageLocation local))
named = PackageSpecifier (SourcePackage (PackageLocation local))
named

    local :: [PackageSpecifier UnresolvedSourcePackage]
local = PackageSpecifier UnresolvedSourcePackage
-> PackageSpecifier UnresolvedSourcePackage
forall {local}.
PackageSpecifier (SourcePackage (PackageLocation local))
-> PackageSpecifier (SourcePackage (PackageLocation local))
sdistize (PackageSpecifier UnresolvedSourcePackage
 -> PackageSpecifier UnresolvedSourcePackage)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx

    gatherTargets :: UnitId -> TargetSelector
    gatherTargets :: UnitId -> TargetSelector
gatherTargets UnitId
targetId = PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pkgName Maybe ComponentKind
targetFilter
      where
        targetUnit :: GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
targetUnit = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> UnitId
-> Map
     UnitId
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (FilePath
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
forall a. HasCallStack => FilePath -> a
error FilePath
"cannot find target unit") UnitId
targetId Map
  UnitId
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
planMap
        PackageIdentifier{PackageName
Version
pkgVersion :: PackageId -> Version
pkgName :: PackageId -> PackageName
pkgName :: PackageName
pkgVersion :: Version
..} = GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
-> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
targetUnit

    targets' :: [TargetSelector]
targets' = (UnitId -> TargetSelector) -> [UnitId] -> [TargetSelector]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitId -> TargetSelector
gatherTargets [UnitId]
targetIds

    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
    hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs = (PackageName
 -> [PackageProperty] -> PackageSpecifier UnresolvedSourcePackage)
-> [PackageProperty]
-> PackageName
-> PackageSpecifier UnresolvedSourcePackage
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName
-> [PackageProperty] -> PackageSpecifier UnresolvedSourcePackage
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage [] (PackageName -> PackageSpecifier UnresolvedSourcePackage)
-> [PackageName] -> [PackageSpecifier UnresolvedSourcePackage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
hackageNames

    hackageTargets :: [TargetSelector]
    hackageTargets :: [TargetSelector]
hackageTargets =
      (PackageName -> Maybe ComponentKind -> TargetSelector)
-> Maybe ComponentKind -> PackageName -> TargetSelector
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed Maybe ComponentKind
targetFilter (PackageName -> TargetSelector)
-> [PackageName] -> [TargetSelector]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
hackageNames

  Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (DistDirLayout -> FilePath
distSdistDirectory DistDirLayout
localDistDirLayout)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TargetsMap -> Bool
forall k a. Map k a -> Bool
Map.null TargetsMap
targets) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [PackageSpecifier UnresolvedSourcePackage]
-> (PackageSpecifier UnresolvedSourcePackage -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx) ((PackageSpecifier UnresolvedSourcePackage -> IO ()) -> IO ())
-> (PackageSpecifier UnresolvedSourcePackage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \PackageSpecifier UnresolvedSourcePackage
lpkg -> case PackageSpecifier UnresolvedSourcePackage
lpkg of
      SpecificSourcePackage UnresolvedSourcePackage
pkg -> Verbosity
-> FilePath
-> OutputFormat
-> FilePath
-> UnresolvedSourcePackage
-> IO ()
packageToSdist Verbosity
verbosity
        (DistDirLayout -> FilePath
distProjectRootDirectory DistDirLayout
localDistDirLayout) OutputFormat
TarGzArchive
        (DistDirLayout -> PackageId -> FilePath
distSdistFile DistDirLayout
localDistDirLayout (UnresolvedSourcePackage -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg)) UnresolvedSourcePackage
pkg
      NamedPackage PackageName
pkgName [PackageProperty]
_ -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Got NamedPackage " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow PackageName
pkgName

  if TargetsMap -> Bool
forall a. Map UnitId a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null TargetsMap
targets
    then ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
hackagePkgs, [TargetSelector]
hackageTargets)
    else ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
local [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs, [TargetSelector]
targets' [TargetSelector] -> [TargetSelector] -> [TargetSelector]
forall a. [a] -> [a] -> [a]
++ [TargetSelector]
hackageTargets)

-- | Partitions the target selectors into known local targets and hackage packages.
partitionToKnownTargetsAndHackagePackages
  :: Verbosity
  -> SourcePackageDb
  -> ElaboratedInstallPlan
  -> [TargetSelector]
  -> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages :: Verbosity
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages Verbosity
verbosity SourcePackageDb
pkgDb ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors = do
  let mTargets :: Either [TargetProblem Void] TargetsMap
mTargets = (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem Void) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem Void) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem Void] TargetsMap
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
        TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
        SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
        ElaboratedInstallPlan
elaboratedPlan
        (SourcePackageDb -> Maybe SourcePackageDb
forall a. a -> Maybe a
Just SourcePackageDb
pkgDb)
        [TargetSelector]
targetSelectors
  case Either [TargetProblem Void] TargetsMap
mTargets of
    Right TargetsMap
targets ->
      -- Everything is a local dependency.
      (TargetsMap, [PackageName]) -> IO (TargetsMap, [PackageName])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetsMap
targets, [])
    Left [TargetProblem Void]
errs     -> do
      -- Not everything is local.
      let
        ([TargetProblem Void]
errs', [PackageName]
hackageNames) = [Either (TargetProblem Void) PackageName]
-> ([TargetProblem Void], [PackageName])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (TargetProblem Void) PackageName]
 -> ([TargetProblem Void], [PackageName]))
-> ((TargetProblem Void -> Either (TargetProblem Void) PackageName)
    -> [Either (TargetProblem Void) PackageName])
-> (TargetProblem Void -> Either (TargetProblem Void) PackageName)
-> ([TargetProblem Void], [PackageName])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TargetProblem Void -> Either (TargetProblem Void) PackageName)
 -> [TargetProblem Void]
 -> [Either (TargetProblem Void) PackageName])
-> [TargetProblem Void]
-> (TargetProblem Void -> Either (TargetProblem Void) PackageName)
-> [Either (TargetProblem Void) PackageName]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TargetProblem Void -> Either (TargetProblem Void) PackageName)
-> [TargetProblem Void]
-> [Either (TargetProblem Void) PackageName]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TargetProblem Void]
errs ((TargetProblem Void -> Either (TargetProblem Void) PackageName)
 -> ([TargetProblem Void], [PackageName]))
-> (TargetProblem Void -> Either (TargetProblem Void) PackageName)
-> ([TargetProblem Void], [PackageName])
forall a b. (a -> b) -> a -> b
$ \case
          TargetAvailableInIndex PackageName
name -> PackageName -> Either (TargetProblem Void) PackageName
forall a b. b -> Either a b
Right PackageName
name
          TargetProblem Void
err                         -> TargetProblem Void -> Either (TargetProblem Void) PackageName
forall a b. a -> Either a b
Left TargetProblem Void
err

      -- report incorrect case for known package.
      [TargetProblem Void] -> (TargetProblem Void -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TargetProblem Void]
errs' ((TargetProblem Void -> IO ()) -> IO ())
-> (TargetProblem Void -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        TargetNotInProject PackageName
hn ->
          case PackageIndex UnresolvedSourcePackage
-> FilePath -> [(PackageName, [UnresolvedSourcePackage])]
forall pkg. PackageIndex pkg -> FilePath -> [(PackageName, [pkg])]
searchByName (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
pkgDb) (PackageName -> FilePath
unPackageName PackageName
hn) of
            [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [(PackageName, [UnresolvedSourcePackage])]
xs -> Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO ())
-> ([FilePath] -> FilePath) -> [FilePath] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall a b. (a -> b) -> a -> b
$
              [ FilePath
"Unknown package \"", PackageName -> FilePath
unPackageName PackageName
hn, FilePath
"\". "
              , FilePath
"Did you mean any of the following?\n"
              , [FilePath] -> FilePath
unlines ((FilePath
"- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> ((PackageName, [UnresolvedSourcePackage]) -> FilePath)
-> (PackageName, [UnresolvedSourcePackage])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> ((PackageName, [UnresolvedSourcePackage]) -> PackageName)
-> (PackageName, [UnresolvedSourcePackage])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, [UnresolvedSourcePackage]) -> PackageName
forall a b. (a, b) -> a
fst ((PackageName, [UnresolvedSourcePackage]) -> FilePath)
-> [(PackageName, [UnresolvedSourcePackage])] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
              ]
        TargetProblem Void
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool)
-> ([TargetProblem Void] -> Bool) -> [TargetProblem Void] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TargetProblem Void] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([TargetProblem Void] -> Bool) -> [TargetProblem Void] -> Bool
forall a b. (a -> b) -> a -> b
$ [TargetProblem Void]
errs') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> [TargetProblem Void] -> IO ()
forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity [TargetProblem Void]
errs'

      let
        targetSelectors' :: [TargetSelector]
targetSelectors' = ((TargetSelector -> Bool) -> [TargetSelector] -> [TargetSelector])
-> [TargetSelector] -> (TargetSelector -> Bool) -> [TargetSelector]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TargetSelector -> Bool) -> [TargetSelector] -> [TargetSelector]
forall a. (a -> Bool) -> [a] -> [a]
filter [TargetSelector]
targetSelectors ((TargetSelector -> Bool) -> [TargetSelector])
-> (TargetSelector -> Bool) -> [TargetSelector]
forall a b. (a -> b) -> a -> b
$ \case
          TargetComponentUnknown PackageName
name Either UnqualComponentName ComponentName
_ SubComponentTarget
_
            | PackageName
name PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
          TargetPackageNamed PackageName
name Maybe ComponentKind
_
            | PackageName
name PackageName -> [PackageName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
          TargetSelector
_                            -> Bool
True

      -- This can't fail, because all of the errors are
      -- removed (or we've given up).
      TargetsMap
targets <-
        ([TargetProblem Void] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem Void] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetProblem Void] -> IO TargetsMap
forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem Void] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem Void] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
        (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem Void) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem Void) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem Void] TargetsMap
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
          TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
          SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
          ElaboratedInstallPlan
elaboratedPlan
          Maybe SourcePackageDb
forall a. Maybe a
Nothing
          [TargetSelector]
targetSelectors'

      (TargetsMap, [PackageName]) -> IO (TargetsMap, [PackageName])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetsMap
targets, [PackageName]
hackageNames)



constructProjectBuildContext
  :: Verbosity
  -> ProjectBaseContext
     -- ^ The synthetic base context to use to produce the full build context.
  -> [TargetSelector]
  -> IO ProjectBuildContext
constructProjectBuildContext :: Verbosity
-> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext
constructProjectBuildContext Verbosity
verbosity ProjectBaseContext
baseCtx [TargetSelector]
targetSelectors = do
  Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ((ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 -> IO ProjectBuildContext)
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
    -- Interpret the targets on the command line as build targets
    TargetsMap
targets <- ([TargetProblem Void] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem Void] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetProblem Void] -> IO TargetsMap
forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem Void] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem Void] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
      (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem Void) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem Void) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem Void] TargetsMap
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
        TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
        SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
        ElaboratedInstallPlan
elaboratedPlan
        Maybe SourcePackageDb
forall a. Maybe a
Nothing
        [TargetSelector]
targetSelectors

    let prunedToTargetsElaboratedPlan :: ElaboratedInstallPlan
prunedToTargetsElaboratedPlan =
          TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets TargetAction
TargetActionBuild TargetsMap
targets ElaboratedInstallPlan
elaboratedPlan
    ElaboratedInstallPlan
prunedElaboratedPlan <-
      if BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
      then (CannotPruneDependencies -> IO ElaboratedInstallPlan)
-> (ElaboratedInstallPlan -> IO ElaboratedInstallPlan)
-> Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> CannotPruneDependencies -> IO ElaboratedInstallPlan
forall a. Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies Verbosity
verbosity) ElaboratedInstallPlan -> IO ElaboratedInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CannotPruneDependencies ElaboratedInstallPlan
 -> IO ElaboratedInstallPlan)
-> Either CannotPruneDependencies ElaboratedInstallPlan
-> IO ElaboratedInstallPlan
forall a b. (a -> b) -> a -> b
$
           Set UnitId
-> ElaboratedInstallPlan
-> Either CannotPruneDependencies ElaboratedInstallPlan
pruneInstallPlanToDependencies (TargetsMap -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet TargetsMap
targets)
                                          ElaboratedInstallPlan
prunedToTargetsElaboratedPlan
      else ElaboratedInstallPlan -> IO ElaboratedInstallPlan
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ElaboratedInstallPlan
prunedToTargetsElaboratedPlan

    (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
prunedElaboratedPlan, TargetsMap
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
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx Platform
platform Compiler
compiler
            ConfigFlags
configFlags ClientInstallFlags
clientInstallFlags = do
  FilePath
installPath <- IO FilePath
defaultInstallPath
  let storeDirLayout :: StoreDirLayout
storeDirLayout = CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout (CabalDirLayout -> StoreDirLayout)
-> CabalDirLayout -> StoreDirLayout
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx

      prefix :: FilePath
prefix = FilePath -> Flag FilePath -> FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault FilePath
"" ((PathTemplate -> FilePath) -> Flag PathTemplate -> Flag FilePath
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> FilePath
InstallDirs.fromPathTemplate (ConfigFlags -> Flag PathTemplate
configProgPrefix ConfigFlags
configFlags))
      suffix :: FilePath
suffix = FilePath -> Flag FilePath -> FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault FilePath
"" ((PathTemplate -> FilePath) -> Flag PathTemplate -> Flag FilePath
forall a b. (a -> b) -> Flag a -> Flag b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> FilePath
InstallDirs.fromPathTemplate (ConfigFlags -> Flag PathTemplate
configProgSuffix ConfigFlags
configFlags))

      mkUnitBinDir :: UnitId -> FilePath
      mkUnitBinDir :: UnitId -> FilePath
mkUnitBinDir =
        InstallDirs FilePath -> FilePath
forall dir. InstallDirs dir -> dir
InstallDirs.bindir (InstallDirs FilePath -> FilePath)
-> (UnitId -> InstallDirs FilePath) -> UnitId -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
        StoreDirLayout -> CompilerId -> UnitId -> InstallDirs FilePath
storePackageInstallDirs' StoreDirLayout
storeDirLayout (Compiler -> CompilerId
compilerId Compiler
compiler)

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

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

  FilePath
installdir <- IO FilePath -> Flag (IO FilePath) -> IO FilePath
forall a. a -> Flag a -> a
fromFlagOrDefault
                (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
installdirUnknown IO () -> IO FilePath -> IO FilePath
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
installPath) (Flag (IO FilePath) -> IO FilePath)
-> Flag (IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$
                FilePath -> IO FilePath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath) -> Flag FilePath -> Flag (IO FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientInstallFlags -> Flag FilePath
cinstInstalldir ClientInstallFlags
clientInstallFlags
  Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
installdir
  Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes Verbosity
verbosity ProjectBuildContext
buildCtx

  InstallMethod
installMethod <- IO InstallMethod
-> (InstallMethod -> IO InstallMethod)
-> Flag InstallMethod
-> IO InstallMethod
forall b a. b -> (a -> b) -> Flag a -> b
flagElim IO InstallMethod
defaultMethod InstallMethod -> IO InstallMethod
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Flag InstallMethod -> IO InstallMethod)
-> Flag InstallMethod -> IO InstallMethod
forall a b. (a -> b) -> a -> b
$
    ClientInstallFlags -> Flag InstallMethod
cinstInstallMethod ClientInstallFlags
clientInstallFlags

  let
    doInstall :: (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
doInstall = Verbosity
-> OverwritePolicy
-> (UnitId -> FilePath)
-> (UnqualComponentName -> FilePath)
-> (UnqualComponentName -> FilePath)
-> FilePath
-> InstallMethod
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> IO ()
installUnitExes
                  Verbosity
verbosity
                  OverwritePolicy
overwritePolicy
                  UnitId -> FilePath
mkUnitBinDir UnqualComponentName -> FilePath
mkExeName UnqualComponentName -> FilePath
mkFinalExeName
                  FilePath
installdir InstallMethod
installMethod
    in ((UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ())
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
doInstall ([(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])] -> IO ())
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> IO ()
forall a b. (a -> b) -> a -> b
$ TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
forall k a. Map k a -> [(k, a)]
Map.toList (TargetsMap
 -> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])])
-> TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx
  where
    overwritePolicy :: OverwritePolicy
overwritePolicy = OverwritePolicy -> Flag OverwritePolicy -> OverwritePolicy
forall a. a -> Flag a -> a
fromFlagOrDefault OverwritePolicy
NeverOverwrite (Flag OverwritePolicy -> OverwritePolicy)
-> Flag OverwritePolicy -> OverwritePolicy
forall a b. (a -> b) -> a -> b
$
                      ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy ClientInstallFlags
clientInstallFlags
    isWindows :: Bool
isWindows = OS
buildOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows

    -- This is in IO as we will make environment checks,
    -- to decide which method is best
    defaultMethod :: IO InstallMethod
    defaultMethod :: IO InstallMethod
defaultMethod
      -- Try symlinking in temporary directory, if it works default to
      -- symlinking even on windows
      | Bool
isWindows = do
        Bool
symlinks <- Verbosity -> IO Bool
trySymlink Verbosity
verbosity
        InstallMethod -> IO InstallMethod
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallMethod -> IO InstallMethod)
-> InstallMethod -> IO InstallMethod
forall a b. (a -> b) -> a -> b
$ if Bool
symlinks then InstallMethod
InstallMethodSymlink else InstallMethod
InstallMethodCopy
      | Bool
otherwise = InstallMethod -> IO InstallMethod
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstallMethod
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
-> ProjectBuildContext
-> InstalledPackageIndex
-> Compiler
-> PackageDBStack
-> FilePath
-> [GhcEnvironmentFileEntry]
-> IO ()
installLibraries Verbosity
verbosity ProjectBuildContext
buildCtx InstalledPackageIndex
installedIndex Compiler
compiler
                 PackageDBStack
packageDbs' FilePath
envFile [GhcEnvironmentFileEntry]
envEntries = do
  if GhcImplInfo -> Bool
supportsPkgEnvFiles (GhcImplInfo -> Bool) -> GhcImplInfo -> Bool
forall a b. (a -> b) -> a -> b
$ Compiler -> GhcImplInfo
getImplInfo Compiler
compiler
    then do
      let validDb :: PackageDB -> IO Bool
validDb (SpecificPackageDB FilePath
fp) = FilePath -> IO Bool
doesPathExist FilePath
fp
          validDb PackageDB
_ = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
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.
      PackageDBStack
packageDbs <- (PackageDB -> IO Bool) -> PackageDBStack -> IO PackageDBStack
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM PackageDB -> IO Bool
validDb PackageDBStack
packageDbs'
      let
        getLatest :: PackageName -> [InstalledPackageInfo]
getLatest = ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (Maybe InstalledPackageInfo -> [InstalledPackageInfo]
forall a. Maybe a -> [a]
maybeToList (Maybe InstalledPackageInfo -> [InstalledPackageInfo])
-> ((Version, [InstalledPackageInfo])
    -> Maybe InstalledPackageInfo)
-> (Version, [InstalledPackageInfo])
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> Maybe InstalledPackageInfo
forall a. [a] -> Maybe a
safeHead ([InstalledPackageInfo] -> Maybe InstalledPackageInfo)
-> ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> (Version, [InstalledPackageInfo])
-> Maybe InstalledPackageInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd) ([(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [(Version, [InstalledPackageInfo])]
-> [(Version, [InstalledPackageInfo])]
forall a. Int -> [a] -> [a]
take Int
1 ([(Version, [InstalledPackageInfo])]
 -> [(Version, [InstalledPackageInfo])])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [(Version, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, [InstalledPackageInfo])
 -> (Version, [InstalledPackageInfo]) -> Ordering)
-> [(Version, [InstalledPackageInfo])]
-> [(Version, [InstalledPackageInfo])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Version, [InstalledPackageInfo]) -> Down Version)
-> (Version, [InstalledPackageInfo])
-> (Version, [InstalledPackageInfo])
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Version -> Down Version
forall a. a -> Down a
Down (Version -> Down Version)
-> ((Version, [InstalledPackageInfo]) -> Version)
-> (Version, [InstalledPackageInfo])
-> Down Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> Version
forall a b. (a, b) -> a
fst))
                  ([(Version, [InstalledPackageInfo])]
 -> [(Version, [InstalledPackageInfo])])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [(Version, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PI.lookupPackageName InstalledPackageIndex
installedIndex
        globalLatest :: [InstalledPackageInfo]
globalLatest = [[InstalledPackageInfo]] -> [InstalledPackageInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PackageName -> [InstalledPackageInfo]
getLatest (PackageName -> [InstalledPackageInfo])
-> [PackageName] -> [[InstalledPackageInfo]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
globalPackages)
        globalEntries :: [GhcEnvironmentFileEntry]
globalEntries = UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId (UnitId -> GhcEnvironmentFileEntry)
-> (InstalledPackageInfo -> UnitId)
-> InstalledPackageInfo
-> GhcEnvironmentFileEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
installedUnitId (InstalledPackageInfo -> GhcEnvironmentFileEntry)
-> [InstalledPackageInfo] -> [GhcEnvironmentFileEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstalledPackageInfo]
globalLatest
        baseEntries :: [GhcEnvironmentFileEntry]
baseEntries =
          GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack GhcEnvironmentFileEntry
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. a -> [a] -> [a]
: (PackageDB -> GhcEnvironmentFileEntry)
-> PackageDBStack -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb PackageDBStack
packageDbs
        pkgEntries :: [GhcEnvironmentFileEntry]
pkgEntries = [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. Ord a => [a] -> [a]
ordNub ([GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry])
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$
             [GhcEnvironmentFileEntry]
globalEntries
          [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
envEntries
          [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents (ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx)
        contents' :: FilePath
contents' = [GhcEnvironmentFileEntry] -> FilePath
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry]
baseEntries [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
pkgEntries)
      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
envFile)
      FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
envFile (FilePath -> ByteString
BS.pack FilePath
contents')
    else
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"The current compiler doesn't support safely installing libraries, "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"so only executables will be available. (Library installation is "
        FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"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 :: [PackageName]
globalPackages = FilePath -> PackageName
mkPackageName (FilePath -> PackageName) -> [FilePath] -> [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ FilePath
"base" ]

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

    exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just UnqualComponentName
exe
    exeMaybe ComponentTarget
_                                  = Maybe UnqualComponentName
forall a. Maybe a
Nothing

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

environmentFileToSpecifiers
  :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]
  -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers :: forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers InstalledPackageIndex
ipi = (GhcEnvironmentFileEntry
 -> ([PackageSpecifier a],
     [(PackageName, GhcEnvironmentFileEntry)]))
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((GhcEnvironmentFileEntry
  -> ([PackageSpecifier a],
      [(PackageName, GhcEnvironmentFileEntry)]))
 -> [GhcEnvironmentFileEntry]
 -> ([PackageSpecifier a],
     [(PackageName, GhcEnvironmentFileEntry)]))
-> (GhcEnvironmentFileEntry
    -> ([PackageSpecifier a],
        [(PackageName, GhcEnvironmentFileEntry)]))
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
forall a b. (a -> b) -> a -> b
$ \case
    (GhcEnvFilePackageId UnitId
unitId)
        | Just InstalledPackageInfo
          { sourcePackageId :: InstalledPackageInfo -> PackageId
sourcePackageId = PackageIdentifier{PackageName
Version
pkgVersion :: PackageId -> Version
pkgName :: PackageId -> PackageName
pkgName :: PackageName
pkgVersion :: Version
..}, UnitId
installedUnitId :: InstalledPackageInfo -> UnitId
installedUnitId :: UnitId
installedUnitId }
          <- InstalledPackageIndex -> UnitId -> Maybe InstalledPackageInfo
forall a. PackageIndex a -> UnitId -> Maybe a
PI.lookupUnitId InstalledPackageIndex
ipi UnitId
unitId
        , let pkgSpec :: PackageSpecifier pkg
pkgSpec = PackageName -> [PackageProperty] -> PackageSpecifier pkg
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName
                        [VersionRange -> PackageProperty
PackagePropertyVersion (Version -> VersionRange
thisVersion Version
pkgVersion)]
        -> ([PackageSpecifier a
forall {pkg}. PackageSpecifier pkg
pkgSpec], [(PackageName
pkgName, UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId UnitId
installedUnitId)])
    GhcEnvironmentFileEntry
_ -> ([], [])


-- | Disables tests and benchmarks if they weren't explicitly enabled.
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault ConfigFlags
configFlags =
  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
-> (UnitId -> FilePath)
-> (UnqualComponentName -> FilePath)
-> (UnqualComponentName -> FilePath)
-> FilePath
-> InstallMethod
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> IO ()
installUnitExes Verbosity
verbosity OverwritePolicy
overwritePolicy
                UnitId -> FilePath
mkSourceBinDir UnqualComponentName -> FilePath
mkExeName UnqualComponentName -> FilePath
mkFinalExeName
                FilePath
installdir InstallMethod
installMethod
                (UnitId
unit, [(ComponentTarget, NonEmpty TargetSelector)]
components) =
  (UnqualComponentName -> IO ()) -> [UnqualComponentName] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ UnqualComponentName -> IO ()
installAndWarn [UnqualComponentName]
exes
  where
    exes :: [UnqualComponentName]
exes = [Maybe UnqualComponentName] -> [UnqualComponentName]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UnqualComponentName] -> [UnqualComponentName])
-> [Maybe UnqualComponentName] -> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ (ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget -> Maybe UnqualComponentName)
-> ((ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget)
-> (ComponentTarget, NonEmpty TargetSelector)
-> Maybe UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget
forall a b. (a, b) -> a
fst) ((ComponentTarget, NonEmpty TargetSelector)
 -> Maybe UnqualComponentName)
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [Maybe UnqualComponentName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ComponentTarget, NonEmpty TargetSelector)]
components
    exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just UnqualComponentName
exe
    exeMaybe ComponentTarget
_ = Maybe UnqualComponentName
forall a. Maybe a
Nothing
    installAndWarn :: UnqualComponentName -> IO ()
installAndWarn UnqualComponentName
exe = do
      Bool
success <- Verbosity
-> OverwritePolicy
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> InstallMethod
-> IO Bool
installBuiltExe
                   Verbosity
verbosity OverwritePolicy
overwritePolicy
                   (UnitId -> FilePath
mkSourceBinDir UnitId
unit) (UnqualComponentName -> FilePath
mkExeName UnqualComponentName
exe)
                   (UnqualComponentName -> FilePath
mkFinalExeName UnqualComponentName
exe)
                   FilePath
installdir InstallMethod
installMethod
      let errorMessage :: FilePath
errorMessage = case OverwritePolicy
overwritePolicy of
            OverwritePolicy
NeverOverwrite ->
              FilePath
"Path '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath
installdir FilePath -> FilePath -> FilePath
</> UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' already exists. "
              FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"Use --overwrite-policy=always to overwrite."
            -- This shouldn't even be possible, but we keep it in case
            -- symlinking/copying logic changes
            OverwritePolicy
_ ->
              case InstallMethod
installMethod of
                InstallMethod
InstallMethodSymlink -> FilePath
"Symlinking"
                InstallMethod
InstallMethodCopy    ->
                  FilePath
"Copying" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' failed."
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO ()
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
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
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> InstallMethod
-> IO Bool
installBuiltExe Verbosity
verbosity OverwritePolicy
overwritePolicy
                FilePath
sourceDir FilePath
exeName FilePath
finalExeName
                FilePath
installdir InstallMethod
InstallMethodSymlink = do
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Symlinking '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' to '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
destination FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"'"
  OverwritePolicy
-> FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
symlinkBinary
    OverwritePolicy
overwritePolicy
    FilePath
installdir
    FilePath
sourceDir
    FilePath
finalExeName
    FilePath
exeName
  where
    destination :: FilePath
destination = FilePath
installdir FilePath -> FilePath -> FilePath
</> FilePath
finalExeName
installBuiltExe Verbosity
verbosity OverwritePolicy
overwritePolicy
                FilePath
sourceDir FilePath
exeName FilePath
finalExeName
                FilePath
installdir InstallMethod
InstallMethodCopy = do
  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Copying '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
exeName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' to '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
destination FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"'"
  Bool
exists <- FilePath -> IO Bool
doesPathExist FilePath
destination
  case (Bool
exists, OverwritePolicy
overwritePolicy) of
    (Bool
True , OverwritePolicy
NeverOverwrite ) -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    (Bool
True , OverwritePolicy
AlwaysOverwrite) -> IO Bool
overwrite
    (Bool
True , OverwritePolicy
PromptOverwrite) -> IO Bool
maybeOverwrite
    (Bool
False, OverwritePolicy
_              ) -> IO Bool
copy
  where
    source :: FilePath
source      = FilePath
sourceDir FilePath -> FilePath -> FilePath
</> FilePath
exeName
    destination :: FilePath
destination = FilePath
installdir FilePath -> FilePath -> FilePath
</> FilePath
finalExeName
    remove :: IO ()
remove = do
      Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
destination
      if Bool
isDir
      then FilePath -> IO ()
removeDirectory FilePath
destination
      else FilePath -> IO ()
removeFile      FilePath
destination
    copy :: IO Bool
copy = FilePath -> FilePath -> IO ()
copyFile FilePath
source FilePath
destination IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    overwrite :: IO Bool
    overwrite :: IO Bool
overwrite = IO ()
remove IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Bool
copy
    maybeOverwrite :: IO Bool
    maybeOverwrite :: IO Bool
maybeOverwrite
      = FilePath -> IO Bool -> IO Bool
promptRun
        FilePath
"Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
        IO Bool
overwrite

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

    go :: UnitId
       -> [(ComponentTarget, NonEmpty TargetSelector)]
       -> [GhcEnvironmentFileEntry]
    go :: UnitId
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GhcEnvironmentFileEntry]
go UnitId
unitId [(ComponentTarget, NonEmpty TargetSelector)]
targets
      | ((ComponentTarget, NonEmpty TargetSelector) -> Bool)
-> [(ComponentTarget, NonEmpty TargetSelector)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ComponentTarget, NonEmpty TargetSelector) -> Bool
hasLib [(ComponentTarget, NonEmpty TargetSelector)]
targets = [UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId UnitId
unitId]
      | Bool
otherwise          = []


-- | Gets the file path to the request environment file.
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion = do
  FilePath
appDir <- IO FilePath
getGhcAppDir
  case Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (ClientInstallFlags -> Flag FilePath
cinstEnvironmentPath ClientInstallFlags
clientInstallFlags) of
    Just FilePath
spec
      -- Is spec a bare word without any "pathy" content, then it refers to
      -- a named global environment.
      | FilePath -> FilePath
takeBaseName FilePath
spec FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
spec ->
          FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Platform -> Version -> FilePath -> FilePath
getGlobalEnv FilePath
appDir Platform
platform Version
compilerVersion FilePath
spec)
      | Bool
otherwise                 -> do
        FilePath
spec' <- FilePath -> IO FilePath
makeAbsolute FilePath
spec
        Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
spec'
        if Bool
isDir
          -- If spec is a directory, then make an ambient environment inside
          -- that directory.
          then FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Platform -> Version -> FilePath
getLocalEnv FilePath
spec' Platform
platform Version
compilerVersion)
          -- Otherwise, treat it like a literal file path.
          else FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
spec'
    Maybe FilePath
Nothing                       ->
      FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Platform -> Version -> FilePath -> FilePath
getGlobalEnv FilePath
appDir Platform
platform Version
compilerVersion FilePath
"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
-> Bool
-> FilePath
-> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile = do
  Bool
envFileExists <- FilePath -> IO Bool
doesFileExist FilePath
envFile
  [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
filterEnvEntries ([GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry])
-> IO [GhcEnvironmentFileEntry] -> IO [GhcEnvironmentFileEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if
    (CompilerFlavor
compilerFlavor CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC Bool -> Bool -> Bool
|| CompilerFlavor
compilerFlavor CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHCJS)
      Bool -> Bool -> Bool
&& Bool
supportsPkgEnvFiles Bool -> Bool -> Bool
&& Bool
envFileExists
    then IO [GhcEnvironmentFileEntry]
-> (ParseErrorExc -> IO [GhcEnvironmentFileEntry])
-> IO [GhcEnvironmentFileEntry]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FilePath -> IO [GhcEnvironmentFileEntry]
readGhcEnvironmentFile FilePath
envFile) ((ParseErrorExc -> IO [GhcEnvironmentFileEntry])
 -> IO [GhcEnvironmentFileEntry])
-> (ParseErrorExc -> IO [GhcEnvironmentFileEntry])
-> IO [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$ \(ParseErrorExc
_ :: ParseErrorExc) ->
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"The environment file " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
envFile FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
        FilePath
" is unparsable. Libraries cannot be installed.") IO ()
-> IO [GhcEnvironmentFileEntry] -> IO [GhcEnvironmentFileEntry]
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [GhcEnvironmentFileEntry] -> IO [GhcEnvironmentFileEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    else [GhcEnvironmentFileEntry] -> IO [GhcEnvironmentFileEntry]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries :: [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
filterEnvEntries = (GhcEnvironmentFileEntry -> Bool)
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter ((GhcEnvironmentFileEntry -> Bool)
 -> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry])
-> (GhcEnvironmentFileEntry -> Bool)
-> [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$ \case
      GhcEnvFilePackageId UnitId
_ -> Bool
True
      GhcEnvironmentFileEntry
_                     -> Bool
False

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

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

getPackageDbStack
  :: CompilerId
  -> Flag FilePath
  -> Flag FilePath
  -> IO PackageDBStack
getPackageDbStack :: CompilerId -> Flag FilePath -> Flag FilePath -> IO PackageDBStack
getPackageDbStack CompilerId
compilerId Flag FilePath
storeDirFlag Flag FilePath
logsDirFlag = do
  Maybe FilePath
mstoreDir <- (FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse FilePath -> IO FilePath
makeAbsolute (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
storeDirFlag
  let
    mlogsDir :: Maybe FilePath
mlogsDir    = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
logsDirFlag
  CabalDirLayout
cabalLayout <- Maybe FilePath -> Maybe FilePath -> IO CabalDirLayout
mkCabalDirLayout Maybe FilePath
mstoreDir Maybe FilePath
mlogsDir
  PackageDBStack -> IO PackageDBStack
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDBStack -> IO PackageDBStack)
-> PackageDBStack -> IO PackageDBStack
forall a b. (a -> b) -> a -> b
$ StoreDirLayout -> CompilerId -> PackageDBStack
storePackageDBStack (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalLayout) CompilerId
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 :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets

    -- If there are any buildable targets then we select those
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable)
  = [k] -> Either (TargetProblem Void) [k]
forall a b. b -> Either a b
Right [k]
targetsBuildable

    -- If there are targets but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets)
  = TargetProblem Void -> Either (TargetProblem Void) [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem Void
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')

    -- If there are no targets at all then we report that
  | Bool
otherwise
  = TargetProblem Void -> Either (TargetProblem Void) [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem Void
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets'         = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    targetsBuildable :: [k]
targetsBuildable = (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith
                         (TargetSelector -> TargetRequested -> Bool
buildable TargetSelector
targetSelector)
                         [AvailableTarget k]
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 :: TargetSelector -> TargetRequested -> Bool
buildable (TargetPackage TargetImplicitCwd
_ [PackageId]
_  Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    buildable (TargetAllPackages  Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    buildable TargetSelector
_ TargetRequested
_ = Bool
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 :: forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget = SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic

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

reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies :: forall a. Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies Verbosity
verbosity =
    Verbosity -> FilePath -> IO a
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity (FilePath -> IO a)
-> (CannotPruneDependencies -> FilePath)
-> CannotPruneDependencies
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotPruneDependencies -> FilePath
renderCannotPruneDependencies