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

  , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ClientInstallFlags)]
commandOptions      = \ShowOrParseArgs
x -> forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. OptionField a -> Bool
notInstallDirOpt forall a b. (a -> b) -> a -> b
$ forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions ShowOrParseArgs
x
  , commandDefaultFlags :: NixStyleFlags ClientInstallFlags
commandDefaultFlags = 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 forall a b. (a -> b) -> a -> b
$ forall a. OptionField a -> FilePath
optionName OptionField a
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
installDirOptNames
  installDirOptNames :: [FilePath]
installDirOptNames = forall a b. (a -> b) -> [a] -> [b]
map 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', ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
.. } [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    = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientInstallFlags -> Flag Bool
cinstInstallLibs ClientInstallFlags
clientInstallFlags)
    targetFilter :: Maybe ComponentKind
targetFilter   = if Bool
installLibs then forall a. a -> Maybe a
Just ComponentKind
LibKind else forall a. a -> Maybe a
Just ComponentKind
ExeKind
    targetStrings' :: [FilePath]
targetStrings' = if 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 <- 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) =
          forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath]
targetStrings' forall a b. (a -> b) -> a -> b
$
          \FilePath
str -> case forall a. Parsec a => FilePath -> Maybe a
simpleParsec FilePath
str of
            Just (PackageId
pkgId :: PackageId)
              | PackageId -> Version
pkgVersion PackageId
pkgId forall a. Eq a => a -> a -> Bool
/= Version
nullVersion -> forall a b. b -> Either a b
Right PackageId
pkgId
            Maybe PackageId
_                                   -> forall a b. a -> Either a b
Left FilePath
str
        packageSpecifiers :: [PackageSpecifier pkg]
packageSpecifiers =
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PackageId]
packageIds forall a b. (a -> b) -> a -> b
$ \case
          PackageIdentifier{PackageName
Version
pkgName :: PackageId -> PackageName
pkgVersion :: Version
pkgName :: PackageName
pkgVersion :: PackageId -> Version
..}
            | Version
pkgVersion forall a. Eq a => a -> a -> Bool
== Version
nullVersion -> forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName []
            | Bool
otherwise                 -> forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName
                                           [VersionRange -> PackageProperty
PackagePropertyVersion
                                            (Version -> VersionRange
thisVersion Version
pkgVersion)]
        packageTargets :: [TargetSelector]
packageTargets =
          forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed Maybe ComponentKind
targetFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
pkgName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageId]
packageIds

      if 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 forall (m :: * -> *) a. Monad m => a -> m a
return (forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers, [], [TargetSelector]
packageTargets, ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
localBaseCtx)
        else do
          [TargetSelector]
targetSelectors <-
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return
            forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx)
                                    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

          forall (m :: * -> *) a. Monad m => a -> m a
return ( [PackageSpecifier UnresolvedSourcePackage]
specs forall a. [a] -> [a] -> [a]
++ forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers
                 , []
                 , [TargetSelector]
selectors 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
_ | 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity -> FilePath -> IO WithoutProjectTargetSelector
parseWithoutProjectTargetSelector Verbosity
verbosity) [FilePath]
targetStrings'
      let
        projectConfig :: ProjectConfig
projectConfig = ProjectConfig
globalConfig forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig

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

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

        mlogsDir :: Maybe FilePath
mlogsDir = forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigLogsDir
        mstoreDir :: Maybe FilePath
mstoreDir = 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 :: SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex } <- forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext
                                            Verbosity
verbosity BuildTimeSettings
buildSettings
                                            (Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity)

      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WithoutProjectTargetSelector -> [PackageName]
woPackageNames [WithoutProjectTargetSelector]
tss) forall a b. (a -> b) -> a -> b
$ \PackageName
name -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
lookupPackageName PackageIndex UnresolvedSourcePackage
packageIndex PackageName
name)) forall a b. (a -> b) -> a -> b
$ do
          let xs :: [(PackageName, [UnresolvedSourcePackage])]
xs = 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
          forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
            [ FilePath
"Unknown package \"", PackageName -> FilePath
unPackageName PackageName
name, FilePath
"\". "
            ] forall a. [a] -> [a] -> [a]
++ forall {a}. Bool -> [a] -> [a]
emptyIf (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
"- " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
            ]

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

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

  ([PackageSpecifier UnresolvedSourcePackage]
specs, [URI]
uris, [TargetSelector]
targetSelectors, ProjectConfig
config) <-
     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 :: Flag FilePath
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigLogsDir
      },
      projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared = ProjectConfigShared {
        Flag CompilerFlavor
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigHcFlavor,
        Flag FilePath
projectConfigHcPath :: ProjectConfigShared -> Flag FilePath
projectConfigHcPath :: Flag FilePath
projectConfigHcPath,
        Flag FilePath
projectConfigHcPkg :: ProjectConfigShared -> Flag FilePath
projectConfigHcPkg :: Flag FilePath
projectConfigHcPkg,
        Flag FilePath
projectConfigStoreDir :: Flag FilePath
projectConfigStoreDir :: ProjectConfigShared -> Flag FilePath
projectConfigStoreDir
      },
      projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages = PackageConfig {
        MapLast FilePath FilePath
packageConfigProgramPaths :: PackageConfig -> MapLast FilePath FilePath
packageConfigProgramPaths :: MapLast FilePath FilePath
packageConfigProgramPaths,
        MapMappend FilePath [FilePath]
packageConfigProgramArgs :: PackageConfig -> MapMappend FilePath [FilePath]
packageConfigProgramArgs :: MapMappend FilePath [FilePath]
packageConfigProgramArgs,
        NubList FilePath
packageConfigProgramPathExtra :: PackageConfig -> NubList FilePath
packageConfigProgramPathExtra :: NubList FilePath
packageConfigProgramPathExtra
      }
    } = ProjectConfig
config

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

    -- ProgramDb with directly user specified paths
    preProgDb :: ProgramDb
preProgDb =
        [(FilePath, FilePath)] -> ProgramDb -> ProgramDb
userSpecifyPaths (forall k a. Map k a -> [(k, a)]
Map.toList (forall k v. MapLast k v -> Map k v
getMapLast MapLast FilePath FilePath
packageConfigProgramPaths))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, [FilePath])] -> ProgramDb -> ProgramDb
userSpecifyArgss (forall k a. Map k a -> [(k, a)]
Map.toList (forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend FilePath [FilePath]
packageConfigProgramArgs))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath
          (forall a. [a] -> [a] -> [a]
++ [ FilePath -> ProgramSearchPathEntry
ProgramSearchPathDir FilePath
dir
              | FilePath
dir <- forall a. NubList a -> [a]
fromNubList NubList FilePath
packageConfigProgramPathExtra ])
      forall a b. (a -> b) -> a -> b
$ ProgramDb
defaultProgramDb

  -- 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 :: GhcImplInfo -> Bool
supportsPkgEnvFiles :: 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) =
      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

  forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
globalTmp FilePath
"cabal-install." 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 <- forall a. FilePath -> Rebuild a -> IO a
runRebuild FilePath
tmpDir 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 = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName ([PackageSpecifier UnresolvedSourcePackage]
specs forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
        envNames :: Set PackageName
envNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName forall {pkg}. [PackageSpecifier pkg]
envSpecs
        forceInstall :: Bool
forceInstall = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags
        nameIntersection :: Set PackageName
nameIntersection = 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
nameIntersection
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {pkg}. [PackageSpecifier pkg]
envSpecs, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries)
      else if Bool
forceInstall
             then let es :: [PackageSpecifier UnresolvedSourcePackage]
es = forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageSpecifier UnresolvedSourcePackage
e -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName PackageSpecifier UnresolvedSourcePackage
e forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) forall {pkg}. [PackageSpecifier pkg]
envSpecs
                      nge :: [GhcEnvironmentFileEntry]
nge = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, GhcEnvironmentFileEntry)
e -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (PackageName, GhcEnvironmentFileEntry)
e forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) forall a b. (a -> b) -> a -> b
$ [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries
                  in forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageSpecifier UnresolvedSourcePackage]
es, [GhcEnvironmentFileEntry]
nge)
             else forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Packages requested to install already exist in environment file at " forall a. [a] -> [a] -> [a]
++ FilePath
envFile forall a. [a] -> [a] -> [a]
++ FilePath
". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow forall a b. (a -> b) -> a -> b
$ 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 = forall a. PackageIndex a -> [(PackageName, [a])]
PI.allPackagesByName InstalledPackageIndex
installedIndex
        newEnvNames :: Set PackageName
newEnvNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName [PackageSpecifier UnresolvedSourcePackage]
envSpecs'
        installedIndex' :: InstalledPackageIndex
installedIndex' = [InstalledPackageInfo] -> InstalledPackageIndex
PI.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, [InstalledPackageInfo])
p -> forall a b. (a, b) -> a
fst (PackageName, [InstalledPackageInfo])
p forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
newEnvNames) 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' forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
specs forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
                 CurrentCommand
InstallCommand

    ProjectBuildContext
buildCtx <- Verbosity
-> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext
constructProjectBuildContext Verbosity
verbosity (ProjectBaseContext
baseCtx {installedPackages :: Maybe InstalledPackageIndex
installedPackages = forall a. a -> Maybe a
Just InstalledPackageIndex
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!
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun 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 = 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 = forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
                        GlobalFlags
globalFlags
                        NixStyleFlags ClientInstallFlags
flags { configFlags :: ConfigFlags
configFlags = 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 :: MapMappend PackageName PackageConfig
projectConfigSpecificPackage = ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigSpecificPackage ProjectConfig
config
                                       forall a. Semigroup a => a -> a -> a
<> forall k v. Map k v -> MapMappend k v
MapMappend (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, PackageConfig)]
targetPackageConfigs)
    }
  where
    localConfig :: PackageConfig
localConfig = ProjectConfig -> PackageConfig
projectConfigLocalPackages ProjectConfig
config
    targetPackageConfigs :: [(PackageName, PackageConfig)]
targetPackageConfigs = 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.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags forall a. Eq a => a -> a -> Bool
== forall a. a -> Flag a
Flag Bool
True) forall a b. (a -> b) -> a -> b
$
    forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"--enable-tests was specified, but tests can't "
                  forall a. [a] -> [a] -> [a]
++ FilePath
"be enabled in a remote package"
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags forall a. Eq a => a -> a -> Bool
== forall a. a -> Flag a
Flag Bool
True) forall a b. (a -> b) -> a -> b
$
    forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"--enable-benchmarks was specified, but benchmarks can't "
                  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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SavedConfig -> ClientInstallFlags
savedClientInstallFlags SavedConfig
savedConfig 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 =
  forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan Verbosity
reducedVerbosity ProjectBaseContext
localBaseCtx 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 = forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
InstallPlan.toMap ElaboratedInstallPlan
elaboratedPlan
    targetIds :: [UnitId]
targetIds = 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) =
      forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage forall {local}. SourcePackage (PackageLocation local)
spkg'
      where
        sdistPath :: FilePath
sdistPath = DistDirLayout -> PackageId -> FilePath
distSdistFile DistDirLayout
localDistDirLayout (forall pkg. Package pkg => pkg -> PackageId
packageId SourcePackage (PackageLocation local)
spkg)
        spkg' :: SourcePackage (PackageLocation local)
spkg' = SourcePackage (PackageLocation local)
spkg { srcpkgSource :: PackageLocation local
srcpkgSource = forall local. FilePath -> PackageLocation local
LocalTarballPackage FilePath
sdistPath }
    sdistize PackageSpecifier (SourcePackage (PackageLocation local))
named = PackageSpecifier (SourcePackage (PackageLocation local))
named

    local :: [PackageSpecifier UnresolvedSourcePackage]
local = forall {local}.
PackageSpecifier (SourcePackage (PackageLocation local))
-> PackageSpecifier (SourcePackage (PackageLocation local))
sdistize 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 = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall a. HasCallStack => FilePath -> a
error FilePath
"cannot find target unit") UnitId
targetId Map
  UnitId
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
planMap
        PackageIdentifier{PackageName
Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageId -> PackageName
pkgVersion :: PackageId -> Version
..} = forall pkg. Package pkg => pkg -> PackageId
packageId GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
targetUnit

    targets' :: [TargetSelector]
targets' = 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
hackageNames

    hackageTargets :: [TargetSelector]
    hackageTargets :: [TargetSelector]
hackageTargets =
      forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed Maybe ComponentKind
targetFilter 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)

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null TargetsMap
targets) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx) 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 (forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg)) UnresolvedSourcePackage
pkg
      NamedPackage PackageName
pkgName [PackageProperty]
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Got NamedPackage " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow PackageName
pkgName

  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null TargetsMap
targets
    then forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
hackagePkgs, [TargetSelector]
hackageTargets)
    else forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
local forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs, [TargetSelector]
targets' 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 err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
        forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
        forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
        ElaboratedInstallPlan
elaboratedPlan
        (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.
      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) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TargetProblem Void]
errs forall a b. (a -> b) -> a -> b
$ \case
          TargetAvailableInIndex PackageName
name -> forall a b. b -> Either a b
Right PackageName
name
          TargetProblem Void
err                         -> forall a b. a -> Either a b
Left TargetProblem Void
err

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

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

      let
        targetSelectors' :: [TargetSelector]
targetSelectors' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> [a] -> [a]
filter [TargetSelector]
targetSelectors forall a b. (a -> b) -> a -> b
$ \case
          TargetComponentUnknown PackageName
name Either UnqualComponentName ComponentName
_ SubComponentTarget
_
            | PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
          TargetPackageNamed PackageName
name Maybe ComponentKind
_
            | PackageName
name 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 <-
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
        forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
          forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
          forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
          ElaboratedInstallPlan
elaboratedPlan
          forall a. Maybe a
Nothing
          [TargetSelector]
targetSelectors'

      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 forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
    -- Interpret the targets on the command line as build targets
    TargetsMap
targets <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
      forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
        forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
        forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
        ElaboratedInstallPlan
elaboratedPlan
        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 forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
           Set UnitId
-> ElaboratedInstallPlan
-> Either CannotPruneDependencies ElaboratedInstallPlan
pruneInstallPlanToDependencies (forall k a. Map k a -> Set k
Map.keysSet TargetsMap
targets)
                                          ElaboratedInstallPlan
prunedToTargetsElaboratedPlan
      else forall (m :: * -> *) a. Monad m => a -> m a
return ElaboratedInstallPlan
prunedToTargetsElaboratedPlan

    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 forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx

      prefix :: FilePath
prefix = forall a. a -> Flag a -> a
fromFlagOrDefault FilePath
"" (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 = forall a. a -> Flag a -> a
fromFlagOrDefault FilePath
"" (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 =
        forall dir. InstallDirs dir -> dir
InstallDirs.bindir 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 forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
exe 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 "
        forall a. [a] -> [a] -> [a]
++ FilePath
"or use --installdir=<path>. Using default installdir: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
installPath

  FilePath
installdir <- forall a. a -> Flag a -> a
fromFlagOrDefault
                (Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
installdirUnknown forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
installPath) forall a b. (a -> b) -> a -> b
$
                forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall b a. b -> (a -> b) -> Flag a -> b
flagElim IO InstallMethod
defaultMethod forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
doInstall forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx
  where
    overwritePolicy :: OverwritePolicy
overwritePolicy = forall a. a -> Flag a -> a
fromFlagOrDefault OverwritePolicy
NeverOverwrite forall a b. (a -> b) -> a -> b
$
                      ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy ClientInstallFlags
clientInstallFlags
    isWindows :: Bool
isWindows = OS
buildOS 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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
symlinks then InstallMethod
InstallMethodSymlink else InstallMethod
InstallMethodCopy
      | Bool
otherwise = 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 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
_ = 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 <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM PackageDB -> IO Bool
validDb PackageDBStack
packageDbs'
      let
        getLatest :: PackageName -> [InstalledPackageInfo]
getLatest = forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
safeHead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PI.lookupPackageName InstalledPackageIndex
installedIndex
        globalLatest :: [InstalledPackageInfo]
globalLatest = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PackageName -> [InstalledPackageInfo]
getLatest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
globalPackages)
        globalEntries :: [GhcEnvironmentFileEntry]
globalEntries = UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
installedUnitId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstalledPackageInfo]
globalLatest
        baseEntries :: [GhcEnvironmentFileEntry]
baseEntries =
          GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb PackageDBStack
packageDbs
        pkgEntries :: [GhcEnvironmentFileEntry]
pkgEntries = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$
             [GhcEnvironmentFileEntry]
globalEntries
          forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
envEntries
          forall a. [a] -> [a] -> [a]
++ TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents (ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx)
        contents' :: FilePath
contents' = [GhcEnvironmentFileEntry] -> FilePath
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry]
baseEntries 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 forall a b. (a -> b) -> a -> b
$
          FilePath
"The current compiler doesn't support safely installing libraries, "
        forall a. [a] -> [a] -> [a]
++ FilePath
"so only executables will be available. (Library installation is "
        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 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 =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noExes forall a b. (a -> b) -> a -> b
$
    Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
    FilePath
"\n" forall a. Semigroup a => a -> a -> a
<>
    FilePath
"@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" forall a. Semigroup a => a -> a -> a
<>
    FilePath
"@ WARNING: Installation might not be completed as desired! @\n" forall a. Semigroup a => a -> a -> a
<>
    FilePath
"@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" forall a. Semigroup a => a -> a -> a
<>
    FilePath
"The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" forall a. Semigroup a => a -> a -> a
<>
    FilePath
"* You might have wanted to add them as dependencies to your package." forall a. Semigroup a => a -> a -> a
<>
    FilePath
" In this case add \"" forall a. Semigroup a => a -> a -> a
<>
    forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (TargetSelector -> FilePath
showTargetSelector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TargetSelector]
selectors) forall a. Semigroup a => a -> a -> a
<>
    FilePath
"\" to the build-depends field(s) of your package's .cabal file.\n" forall a. Semigroup a => a -> a -> a
<>
    FilePath
"* You might have wanted to add them to a GHC environment. In this case" forall a. Semigroup a => a -> a -> a
<>
    FilePath
" use \"cabal install --lib " forall a. Semigroup a => a -> a -> a
<>
    [FilePath] -> FilePath
unwords (TargetSelector -> FilePath
showTargetSelector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TargetSelector]
selectors) forall a. Semigroup a => a -> a -> a
<> FilePath
"\". " forall a. Semigroup a => a -> a -> a
<>
    FilePath
" The \"--lib\" flag is provisional: see" forall a. Semigroup a => a -> a -> a
<>
    FilePath
" https://github.com/haskell/cabal/issues/6481 for more information."
  where
    targets :: [(ComponentTarget, NonEmpty TargetSelector)]
targets    = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx
    components :: [ComponentTarget]
components = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ComponentTarget, NonEmpty TargetSelector)]
targets
    selectors :: [TargetSelector]
selectors  = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. NonEmpty a -> [a]
NE.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ComponentTarget, NonEmpty TargetSelector)]
targets
    noExes :: Bool
noExes     = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ ComponentTarget -> Maybe UnqualComponentName
exeMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ComponentTarget]
components

    exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = forall a. a -> Maybe a
Just UnqualComponentName
exe
    exeMaybe ComponentTarget
_                                  = 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 (forall {pkg}. [PackageSpecifier pkg]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
envEntries')
  else ([], [(PackageName, GhcEnvironmentFileEntry)]
envEntries')
  where
    ([PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
envEntries') = 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 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a -> b) -> a -> b
$ \case
    (GhcEnvFilePackageId UnitId
unitId)
        | Just InstalledPackageInfo
          { sourcePackageId :: InstalledPackageInfo -> PackageId
sourcePackageId = PackageIdentifier{PackageName
Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageId -> PackageName
pkgVersion :: PackageId -> Version
..}, UnitId
installedUnitId :: UnitId
installedUnitId :: InstalledPackageInfo -> UnitId
installedUnitId }
          <- forall a. PackageIndex a -> UnitId -> Maybe a
PI.lookupUnitId InstalledPackageIndex
ipi UnitId
unitId
        , let pkgSpec :: PackageSpecifier pkg
pkgSpec = forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName
                        [VersionRange -> PackageProperty
PackagePropertyVersion (Version -> VersionRange
thisVersion Version
pkgVersion)]
        -> ([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 Bool
configTests = forall a. a -> Flag a
Flag Bool
False forall a. Semigroup a => a -> a -> a
<> ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags
              , configBenchmarks :: Flag Bool
configBenchmarks = forall a. a -> Flag a
Flag Bool
False forall a. Semigroup a => a -> a -> a
<> ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
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) =
  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 = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ (ComponentTarget -> Maybe UnqualComponentName
exeMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) 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
_) = forall a. a -> Maybe a
Just UnqualComponentName
exe
    exeMaybe ComponentTarget
_ = 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 '" forall a. Semigroup a => a -> a -> a
<> (FilePath
installdir FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe) forall a. Semigroup a => a -> a -> a
<> FilePath
"' already exists. "
              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" forall a. Semigroup a => a -> a -> a
<> FilePath
" '" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe forall a. Semigroup a => a -> a -> a
<> FilePath
"' failed."
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Symlinking '" forall a. Semigroup a => a -> a -> a
<> FilePath
exeName forall a. Semigroup a => a -> a -> a
<> FilePath
"' to '" forall a. Semigroup a => a -> a -> a
<> FilePath
destination 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Copying '" forall a. Semigroup a => a -> a -> a
<> FilePath
exeName forall a. Semigroup a => a -> a -> a
<> FilePath
"' to '" forall a. Semigroup a => a -> a -> a
<> FilePath
destination 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 ) -> 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    overwrite :: IO Bool
    overwrite :: IO Bool
overwrite = IO ()
remove 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 = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' (\UnitId
k [(ComponentTarget, NonEmpty TargetSelector)]
v -> 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
      | 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 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 forall a. Eq a => a -> a -> Bool
== FilePath
spec ->
          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 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 forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
spec'
    Maybe FilePath
Nothing                       ->
      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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if
    (CompilerFlavor
compilerFlavor forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC Bool -> Bool -> Bool
|| CompilerFlavor
compilerFlavor forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHCJS)
      Bool -> Bool -> Bool
&& Bool
supportsPkgEnvFiles Bool -> Bool -> Bool
&& Bool
envFileExists
    then forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FilePath -> IO [GhcEnvironmentFileEntry]
readGhcEnvironmentFile FilePath
envFile) forall a b. (a -> b) -> a -> b
$ \(ParseErrorExc
_ :: ParseErrorExc) ->
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"The environment file " forall a. [a] -> [a] -> [a]
++ FilePath
envFile forall a. [a] -> [a] -> [a]
++
        FilePath
" is unparsable. Libraries cannot be installed.") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
    else 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 = forall a. (a -> Bool) -> [a] -> [a]
filter 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." 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 <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> IO FilePath
makeAbsolute forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
storeDirFlag
  let
    mlogsDir :: Maybe FilePath
mlogsDir    = 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable)
  = 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets)
  = forall a b. a -> Either a b
Left (forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')

    -- If there are no targets at all then we report that
  | Bool
otherwise
  = forall a b. a -> Either a b
Left (forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets'         = forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    targetsBuildable :: [k]
targetsBuildable = 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 = 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 = 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 =
    forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotPruneDependencies -> FilePath
renderCannotPruneDependencies