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

-- | 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 Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
  ( doesPathExist
  )
import Prelude ()

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

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

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

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

-- | Check or check then install an exe. The check is to see if the overwrite
-- policy allows installation.
data InstallCheck
  = -- | Only check if install is permitted.
    InstallCheckOnly
  | -- | Actually install but check first if permitted.
    InstallCheckInstall

type InstallAction =
  Verbosity
  -> OverwritePolicy
  -> InstallExe
  -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
  -> IO ()

data InstallCfg = InstallCfg
  { InstallCfg -> Verbosity
verbosity :: Verbosity
  , InstallCfg -> ProjectBaseContext
baseCtx :: ProjectBaseContext
  , InstallCfg -> ProjectBuildContext
buildCtx :: ProjectBuildContext
  , InstallCfg -> Platform
platform :: Platform
  , InstallCfg -> Compiler
compiler :: Compiler
  , InstallCfg -> ConfigFlags
installConfigFlags :: ConfigFlags
  , InstallCfg -> ClientInstallFlags
installClientFlags :: ClientInstallFlags
  }

-- | A record of install method, install directory and file path functions
-- needed by actions that either check if an install is possible or actually
-- perform an installation. This is for installation of executables only.
data InstallExe = InstallExe
  { InstallExe -> InstallMethod
installMethod :: InstallMethod
  , InstallExe -> FilePath
installDir :: FilePath
  , InstallExe -> UnitId -> FilePath
mkSourceBinDir :: UnitId -> FilePath
  -- ^ A function to get an UnitId's store directory.
  , InstallExe -> UnqualComponentName -> FilePath
mkExeName :: UnqualComponentName -> FilePath
  -- ^ A function to get an exe's filename.
  , InstallExe -> UnqualComponentName -> FilePath
mkFinalExeName :: UnqualComponentName -> FilePath
  -- ^ A function to get an exe's final possibly different to the name in the
  -- store.
  }

installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
installCommand =
  CommandUI
    { commandName :: FilePath
commandName = FilePath
"v2-install"
    , commandSynopsis :: FilePath
commandSynopsis = FilePath
"Install packages."
    , commandUsage :: FilePath -> FilePath
commandUsage =
        FilePath -> [FilePath] -> FilePath -> FilePath
usageAlternatives
          FilePath
"v2-install"
          [FilePath
"[TARGETS] [FLAGS]"]
    , commandDescription :: Maybe (FilePath -> FilePath)
commandDescription = (FilePath -> FilePath) -> Maybe (FilePath -> FilePath)
forall a. a -> Maybe a
Just ((FilePath -> FilePath) -> Maybe (FilePath -> FilePath))
-> (FilePath -> FilePath) -> Maybe (FilePath -> FilePath)
forall a b. (a -> b) -> a -> b
$ \FilePath
_ ->
        FilePath -> FilePath
wrapText (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
          FilePath
"Installs one or more packages. This is done by installing them "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"in the store and symlinking or copying the executables in the directory "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"specified by the --installdir flag (`~/.local/bin/` by default). "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"If you want the installed executables to be available globally, "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"make sure that the PATH environment variable contains that directory. "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n\n"
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"If TARGET is a library and --lib (provisional) is used, "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"it will be added to the global environment. "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"When doing this, cabal will try to build a plan that includes all "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"the previously installed libraries. This is currently not implemented."
    , commandNotes :: Maybe (FilePath -> FilePath)
commandNotes = (FilePath -> FilePath) -> Maybe (FilePath -> FilePath)
forall a. a -> Maybe a
Just ((FilePath -> FilePath) -> Maybe (FilePath -> FilePath))
-> (FilePath -> FilePath) -> Maybe (FilePath -> FilePath)
forall a b. (a -> b) -> a -> b
$ \FilePath
pname ->
        FilePath
"Examples:\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"  "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pname
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" v2-install\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"    Install the package in the current directory\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"  "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pname
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" v2-install pkgname\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"    Install the package named pkgname"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (fetching it from hackage if necessary)\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"  "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pname
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" v2-install ./pkgfoo\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"    Install the package in the ./pkgfoo directory\n"
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ClientInstallFlags)]
commandOptions = \ShowOrParseArgs
x -> (OptionField (NixStyleFlags ClientInstallFlags) -> Bool)
-> [OptionField (NixStyleFlags ClientInstallFlags)]
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a. (a -> Bool) -> [a] -> [a]
filter OptionField (NixStyleFlags ClientInstallFlags) -> Bool
forall {a}. OptionField a -> Bool
notInstallDirOpt ([OptionField (NixStyleFlags ClientInstallFlags)]
 -> [OptionField (NixStyleFlags ClientInstallFlags)])
-> [OptionField (NixStyleFlags ClientInstallFlags)]
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a b. (a -> b) -> a -> b
$ (ShowOrParseArgs -> [OptionField ClientInstallFlags])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions ShowOrParseArgs
x
    , commandDefaultFlags :: NixStyleFlags ClientInstallFlags
commandDefaultFlags = ClientInstallFlags -> NixStyleFlags ClientInstallFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ClientInstallFlags
defaultClientInstallFlags
    }
  where
    -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.
    notInstallDirOpt :: OptionField a -> Bool
notInstallDirOpt OptionField a
x = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ OptionField a -> FilePath
forall a. OptionField a -> FilePath
optionName OptionField a
x FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
installDirOptNames
    installDirOptNames :: [FilePath]
installDirOptNames = (OptionField (InstallDirs (Flag PathTemplate)) -> FilePath)
-> [OptionField (InstallDirs (Flag PathTemplate))] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map OptionField (InstallDirs (Flag PathTemplate)) -> FilePath
forall a. OptionField a -> FilePath
optionName [OptionField (InstallDirs (Flag PathTemplate))]
installDirsOptions

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

  -- We cannot use establishDummyProjectBaseContext to get these flags, since
  -- it requires one of them as an argument. Normal establishProjectBaseContext
  -- does not, and this is why this is done only for the install command
  ClientInstallFlags
clientInstallFlags <- Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
extraFlags
  let
    installLibs :: Bool
installLibs = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientInstallFlags -> Flag Bool
cinstInstallLibs ClientInstallFlags
clientInstallFlags)

    normalisedTargetStrings :: [FilePath]
normalisedTargetStrings = if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings then [FilePath
"."] else [FilePath]
targetStrings

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

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

  ([PackageSpecifier UnresolvedSourcePackage]
pkgSpecs, [URI]
uris, [TargetSelector]
targetSelectors, ProjectConfig
config) <-
    let
      with :: IO
  ([PackageSpecifier UnresolvedSourcePackage], [a], [TargetSelector],
   ProjectConfig)
with = do
        ([PackageSpecifier UnresolvedSourcePackage]
pkgSpecs, [TargetSelector]
targetSelectors, ProjectConfig
baseConfig) <-
          Verbosity
-> ProjectConfig
-> [FilePath]
-> Bool
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector],
      ProjectConfig)
withProject Verbosity
verbosity ProjectConfig
cliConfig [FilePath]
normalisedTargetStrings Bool
installLibs
        -- No URIs in this case, see note above
        ([PackageSpecifier UnresolvedSourcePackage], [a], [TargetSelector],
 ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [a], [TargetSelector],
      ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
pkgSpecs, [], [TargetSelector]
targetSelectors, ProjectConfig
baseConfig)

      without :: IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
without =
        Verbosity
-> Flag FilePath
-> (ProjectConfig
    -> IO
         ([PackageSpecifier UnresolvedSourcePackage], [URI],
          [TargetSelector], ProjectConfig))
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a.
Verbosity -> Flag FilePath -> (ProjectConfig -> IO a) -> IO a
withGlobalConfig Verbosity
verbosity Flag FilePath
globalConfigFlag ((ProjectConfig
  -> IO
       ([PackageSpecifier UnresolvedSourcePackage], [URI],
        [TargetSelector], ProjectConfig))
 -> IO
      ([PackageSpecifier UnresolvedSourcePackage], [URI],
       [TargetSelector], ProjectConfig))
-> (ProjectConfig
    -> IO
         ([PackageSpecifier UnresolvedSourcePackage], [URI],
          [TargetSelector], ProjectConfig))
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a b. (a -> b) -> a -> b
$ \ProjectConfig
globalConfig ->
          Verbosity
-> ProjectConfig
-> [FilePath]
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
withoutProject Verbosity
verbosity (ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig) [FilePath]
normalisedTargetStrings
     in
      -- If there's no targets it does not make sense to not be in a project.
      if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings
        then IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
forall {a}.
IO
  ([PackageSpecifier UnresolvedSourcePackage], [a], [TargetSelector],
   ProjectConfig)
with
        else Flag Bool
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a. Flag Bool -> IO a -> IO a -> IO a
withProjectOrGlobalConfig Flag Bool
ignoreProject IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
forall {a}.
IO
  ([PackageSpecifier UnresolvedSourcePackage], [a], [TargetSelector],
   ProjectConfig)
with IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
without

  -- NOTE: CmdInstall and project local packages.
  --
  -- CmdInstall always installs packages from a source distribution that, in case of unpackage
  -- pacakges, is created automatically. This is implemented in getSpecsAndTargetSelectors.
  --
  -- This has the inconvenience that the planner will consider all packages as non-local
  -- (see `ProjectPlanning.shouldBeLocal`) and that any project or cli configuration will
  -- not apply to them.
  --
  -- We rectify this here. In the project configuration, we copy projectConfigLocalPackages to a
  -- new projectConfigSpecificPackage entry for each package corresponding to a target selector.
  --
  -- See #8637 and later #7297, #8909, #7236.

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

    hcFlavor :: Maybe CompilerFlavor
hcFlavor = Flag CompilerFlavor -> Maybe CompilerFlavor
forall a. Flag a -> Maybe a
flagToMaybe Flag CompilerFlavor
projectConfigHcFlavor
    hcPath :: Maybe FilePath
hcPath = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHcPath
    hcPkg :: Maybe FilePath
hcPkg = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHcPkg
    extraPath :: [FilePath]
extraPath = NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList NubList FilePath
packageConfigProgramPathExtra [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ NubList FilePath -> [FilePath]
forall a. NubList a -> [a]
fromNubList NubList FilePath
projectConfigProgPathExtra

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

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

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

  (Bool
usedPackageEnvFlag, FilePath
envFile) <- ClientInstallFlags -> Platform -> Version -> IO (Bool, FilePath)
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion
  (Bool
usedExistingPkgEnvFile, [GhcEnvironmentFileEntry FilePath]
existingEnvEntries) <-
    Verbosity
-> CompilerFlavor
-> Bool
-> FilePath
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile
  PackageDBStackCWD
packageDbs <- Compiler
-> Flag FilePath
-> Flag FilePath
-> [Maybe PackageDBCWD]
-> IO PackageDBStackCWD
getPackageDbStack Compiler
compiler Flag FilePath
projectConfigStoreDir Flag FilePath
projectConfigLogsDir [Maybe PackageDBCWD]
projectConfigPackageDBs
  InstalledPackageIndex
installedIndex <- Verbosity
-> Compiler
-> PackageDBStackCWD
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
compiler PackageDBStackCWD
packageDbs ProgramDb
progDb

  let
    ([PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry FilePath)]
nonGlobalEnvEntries) =
      InstalledPackageIndex
-> [GhcEnvironmentFileEntry FilePath]
-> Bool
-> ([PackageSpecifier a],
    [(PackageName, GhcEnvironmentFileEntry FilePath)])
forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry FilePath]
-> Bool
-> ([PackageSpecifier a],
    [(PackageName, GhcEnvironmentFileEntry FilePath)])
getEnvSpecsAndNonGlobalEntries InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry FilePath]
existingEnvEntries Bool
installLibs

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

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

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

    -- check for targets already in env
    let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
        getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName = PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget
        targetNames :: Set PackageName
targetNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
S.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName ([PackageSpecifier UnresolvedSourcePackage]
pkgSpecs [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
        envNames :: Set PackageName
envNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
S.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName [PackageSpecifier UnresolvedSourcePackage]
forall {a}. [PackageSpecifier a]
envSpecs
        forceInstall :: Bool
forceInstall = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags
        nameIntersection :: Set PackageName
nameIntersection = Set PackageName -> Set PackageName -> Set PackageName
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set PackageName
targetNames Set PackageName
envNames

    -- we check for intersections in targets with the existing env
    ([PackageSpecifier UnresolvedSourcePackage]
envSpecs', [GhcEnvironmentFileEntry FilePath]
nonGlobalEnvEntries') <-
      if Set PackageName -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
nameIntersection
        then ([PackageSpecifier UnresolvedSourcePackage],
 [GhcEnvironmentFileEntry FilePath])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageSpecifier UnresolvedSourcePackage]
forall {a}. [PackageSpecifier a]
envSpecs, ((PackageName, GhcEnvironmentFileEntry FilePath)
 -> GhcEnvironmentFileEntry FilePath)
-> [(PackageName, GhcEnvironmentFileEntry FilePath)]
-> [GhcEnvironmentFileEntry FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, GhcEnvironmentFileEntry FilePath)
-> GhcEnvironmentFileEntry FilePath
forall a b. (a, b) -> b
snd [(PackageName, GhcEnvironmentFileEntry FilePath)]
nonGlobalEnvEntries)
        else
          if Bool
forceInstall
            then
              let es :: [PackageSpecifier UnresolvedSourcePackage]
es = (PackageSpecifier UnresolvedSourcePackage -> Bool)
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageSpecifier UnresolvedSourcePackage
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName PackageSpecifier UnresolvedSourcePackage
e PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) [PackageSpecifier UnresolvedSourcePackage]
forall {a}. [PackageSpecifier a]
envSpecs
                  nge :: [GhcEnvironmentFileEntry FilePath]
nge = ((PackageName, GhcEnvironmentFileEntry FilePath)
 -> GhcEnvironmentFileEntry FilePath)
-> [(PackageName, GhcEnvironmentFileEntry FilePath)]
-> [GhcEnvironmentFileEntry FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, GhcEnvironmentFileEntry FilePath)
-> GhcEnvironmentFileEntry FilePath
forall a b. (a, b) -> b
snd ([(PackageName, GhcEnvironmentFileEntry FilePath)]
 -> [GhcEnvironmentFileEntry FilePath])
-> ([(PackageName, GhcEnvironmentFileEntry FilePath)]
    -> [(PackageName, GhcEnvironmentFileEntry FilePath)])
-> [(PackageName, GhcEnvironmentFileEntry FilePath)]
-> [GhcEnvironmentFileEntry FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, GhcEnvironmentFileEntry FilePath) -> Bool)
-> [(PackageName, GhcEnvironmentFileEntry FilePath)]
-> [(PackageName, GhcEnvironmentFileEntry FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, GhcEnvironmentFileEntry FilePath)
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PackageName, GhcEnvironmentFileEntry FilePath) -> PackageName
forall a b. (a, b) -> a
fst (PackageName, GhcEnvironmentFileEntry FilePath)
e PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) ([(PackageName, GhcEnvironmentFileEntry FilePath)]
 -> [GhcEnvironmentFileEntry FilePath])
-> [(PackageName, GhcEnvironmentFileEntry FilePath)]
-> [GhcEnvironmentFileEntry FilePath]
forall a b. (a -> b) -> a -> b
$ [(PackageName, GhcEnvironmentFileEntry FilePath)]
nonGlobalEnvEntries
               in ([PackageSpecifier UnresolvedSourcePackage],
 [GhcEnvironmentFileEntry FilePath])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry FilePath])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageSpecifier UnresolvedSourcePackage]
es, [GhcEnvironmentFileEntry FilePath]
nge)
            else Verbosity
-> CabalInstallException
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry FilePath])
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException
 -> IO
      ([PackageSpecifier UnresolvedSourcePackage],
       [GhcEnvironmentFileEntry FilePath]))
-> CabalInstallException
-> IO
     ([PackageSpecifier UnresolvedSourcePackage],
      [GhcEnvironmentFileEntry FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> CabalInstallException
PackagesAlreadyExistInEnvfile FilePath
envFile ((PackageName -> FilePath) -> [PackageName] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ([PackageName] -> [FilePath]) -> [PackageName] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
S.toList Set PackageName
nameIntersection)

    -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that
    -- we can solve with regards to packages installed locally but not in the upstream repo
    let installedPacks :: [(PackageName, [InstalledPackageInfo])]
installedPacks = InstalledPackageIndex -> [(PackageName, [InstalledPackageInfo])]
forall a. PackageIndex a -> [(PackageName, [a])]
PI.allPackagesByName InstalledPackageIndex
installedIndex
        newEnvNames :: Set PackageName
newEnvNames = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
S.fromList ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName [PackageSpecifier UnresolvedSourcePackage]
envSpecs'
        installedIndex' :: InstalledPackageIndex
installedIndex' = [InstalledPackageInfo] -> InstalledPackageIndex
PI.fromList ([InstalledPackageInfo] -> InstalledPackageIndex)
-> ([(PackageName, [InstalledPackageInfo])]
    -> [InstalledPackageInfo])
-> [(PackageName, [InstalledPackageInfo])]
-> InstalledPackageIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(PackageName, [InstalledPackageInfo])]
-> [InstalledPackageInfo]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (PackageName, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd ([(PackageName, [InstalledPackageInfo])] -> [InstalledPackageInfo])
-> ([(PackageName, [InstalledPackageInfo])]
    -> [(PackageName, [InstalledPackageInfo])])
-> [(PackageName, [InstalledPackageInfo])]
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, [InstalledPackageInfo]) -> Bool)
-> [(PackageName, [InstalledPackageInfo])]
-> [(PackageName, [InstalledPackageInfo])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, [InstalledPackageInfo])
p -> (PackageName, [InstalledPackageInfo]) -> PackageName
forall a b. (a, b) -> a
fst (PackageName, [InstalledPackageInfo])
p PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
newEnvNames) ([(PackageName, [InstalledPackageInfo])] -> InstalledPackageIndex)
-> [(PackageName, [InstalledPackageInfo])] -> InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$ [(PackageName, [InstalledPackageInfo])]
installedPacks

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

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

    Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx
    let installCfg :: InstallCfg
installCfg = Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> InstallCfg
InstallCfg Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx Platform
platform Compiler
compiler ConfigFlags
configFlags ClientInstallFlags
clientInstallFlags

    let
      dryRun :: Bool
dryRun =
        BuildTimeSettings -> Bool
buildSettingDryRun (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
          Bool -> Bool -> Bool
|| BuildTimeSettings -> Bool
buildSettingOnlyDownload (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)

    -- Before building, check if we could install any built exe by symlinking or
    -- copying it?
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
      (Bool
dryRun Bool -> Bool -> Bool
|| Bool
installLibs)
      (InstallAction -> InstallCfg -> IO ()
traverseInstall (InstallCheck -> InstallAction
installCheckUnitExes InstallCheck
InstallCheckOnly) InstallCfg
installCfg)

    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

    -- Having built everything, do the install.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      if Bool
installLibs
        then
          Verbosity
-> ProjectBuildContext
-> InstalledPackageIndex
-> Compiler
-> PackageDBStackCWD
-> FilePath
-> [GhcEnvironmentFileEntry FilePath]
-> Bool
-> IO ()
installLibraries
            Verbosity
verbosity
            ProjectBuildContext
buildCtx
            InstalledPackageIndex
installedIndex
            Compiler
compiler
            PackageDBStackCWD
packageDbs
            FilePath
envFile
            [GhcEnvironmentFileEntry FilePath]
nonGlobalEnvEntries'
            (Bool -> Bool
not Bool
usedExistingPkgEnvFile Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
usedPackageEnvFlag)
        else -- Install any built exe by symlinking or copying it we don't use
        -- BuildOutcomes because we also need the component names
          InstallAction -> InstallCfg -> IO ()
traverseInstall (InstallCheck -> InstallAction
installCheckUnitExes InstallCheck
InstallCheckInstall) InstallCfg
installCfg
  where
    configFlags' :: ConfigFlags
configFlags' = ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault (ConfigFlags -> ConfigFlags)
-> (ConfigFlags -> ConfigFlags) -> ConfigFlags -> ConfigFlags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConfigFlags -> ConfigFlags
ignoreProgramAffixes (ConfigFlags -> ConfigFlags) -> ConfigFlags -> ConfigFlags
forall a b. (a -> b) -> a -> b
$ ConfigFlags
configFlags
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (CommonSetupFlags -> Flag Verbosity
setupVerbosity (CommonSetupFlags -> Flag Verbosity)
-> CommonSetupFlags -> Flag Verbosity
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> CommonSetupFlags
configCommonFlags ConfigFlags
configFlags')
    ignoreProject :: Flag Bool
ignoreProject = ProjectFlags -> Flag Bool
flagIgnoreProject ProjectFlags
projectFlags
    cliConfig :: ProjectConfig
cliConfig =
      GlobalFlags
-> NixStyleFlags ClientInstallFlags
-> ClientInstallFlags
-> ProjectConfig
forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
        GlobalFlags
globalFlags
        NixStyleFlags ClientInstallFlags
flags{configFlags = configFlags'}
        ClientInstallFlags
extraFlags

    globalConfigFlag :: Flag FilePath
globalConfigFlag = ProjectConfigShared -> Flag FilePath
projectConfigConfigFile (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)

    -- Do the install action for each executable in the install configuration.
    traverseInstall :: InstallAction -> InstallCfg -> IO ()
    traverseInstall :: InstallAction -> InstallCfg -> IO ()
traverseInstall InstallAction
action cfg :: InstallCfg
cfg@InstallCfg{verbosity :: InstallCfg -> Verbosity
verbosity = Verbosity
v, ProjectBuildContext
buildCtx :: InstallCfg -> ProjectBuildContext
buildCtx :: ProjectBuildContext
buildCtx, ClientInstallFlags
installClientFlags :: InstallCfg -> ClientInstallFlags
installClientFlags :: ClientInstallFlags
installClientFlags} = do
      let overwritePolicy :: OverwritePolicy
overwritePolicy = OverwritePolicy -> Flag OverwritePolicy -> OverwritePolicy
forall a. a -> Flag a -> a
fromFlagOrDefault OverwritePolicy
NeverOverwrite (Flag OverwritePolicy -> OverwritePolicy)
-> Flag OverwritePolicy -> OverwritePolicy
forall a b. (a -> b) -> a -> b
$ ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy ClientInstallFlags
installClientFlags
      (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
actionOnExe <- InstallAction
action Verbosity
v OverwritePolicy
overwritePolicy (InstallExe
 -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ())
-> IO InstallExe
-> IO
     ((UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InstallCfg -> IO InstallExe
prepareExeInstall InstallCfg
cfg
      ((UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ())
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
-> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
actionOnExe ([(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])] -> IO ())
-> (TargetsMap
    -> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])])
-> TargetsMap
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetsMap
-> [(UnitId, [(ComponentTarget, NonEmpty TargetSelector)])]
forall k a. Map k a -> [(k, a)]
Map.toList (TargetsMap -> IO ()) -> TargetsMap -> IO ()
forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx

withProject
  :: Verbosity
  -> ProjectConfig
  -> [String]
  -> Bool
  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig)
withProject :: Verbosity
-> ProjectConfig
-> [FilePath]
-> Bool
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector],
      ProjectConfig)
withProject Verbosity
verbosity ProjectConfig
cliConfig [FilePath]
targetStrings Bool
installLibs = do
  -- First, we need to learn about what's available to be installed.
  ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
reducedVerbosity ProjectConfig
cliConfig CurrentCommand
InstallCommand

  ([PackageSpecifier UnresolvedSourcePackage]
pkgSpecs, [TargetSelector]
targetSelectors) <-
    -- If every target is already resolved to a package id, we can return without any further parsing.
    if [FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
unresolvedTargetStrings
      then ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
forall {a}. [PackageSpecifier a]
parsedPkgSpecs, [TargetSelector]
parsedTargets)
      else do
        -- Anything that could not be parsed as a packageId (e.g. a package name without a version or
        -- a target syntax using colons) must be resolved inside the project context.
        ([PackageSpecifier UnresolvedSourcePackage]
resolvedPkgSpecs, [TargetSelector]
resolvedTargets) <-
          Verbosity
-> ProjectBaseContext
-> [FilePath]
-> Maybe ComponentKindFilter
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
resolveTargetSelectorsInProjectBaseContext Verbosity
verbosity ProjectBaseContext
baseCtx [FilePath]
unresolvedTargetStrings Maybe ComponentKindFilter
targetFilter
        ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
resolvedPkgSpecs [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
-> [PackageSpecifier UnresolvedSourcePackage]
forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
forall {a}. [PackageSpecifier a]
parsedPkgSpecs, [TargetSelector]
resolvedTargets [TargetSelector] -> [TargetSelector] -> [TargetSelector]
forall a. [a] -> [a] -> [a]
++ [TargetSelector]
parsedTargets)

  -- Apply the local configuration (e.g. cli flags) to all direct targets of install command, see note
  -- in 'installAction'.
  --
  -- NOTE: If a target string had to be resolved inside the project context, then pkgSpecs will include
  -- the project packages turned into source distributions (getSpecsAndTargetSelectors does this).
  -- We want to apply the local configuration only to the actual targets.
  let config :: ProjectConfig
config =
        ProjectConfig -> [PackageName] -> ProjectConfig
addLocalConfigToPkgs (ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
baseCtx) ([PackageName] -> ProjectConfig) -> [PackageName] -> ProjectConfig
forall a b. (a -> b) -> a -> b
$
          (TargetSelector -> [PackageName])
-> [TargetSelector] -> [PackageName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([PackageSpecifier UnresolvedSourcePackage]
-> TargetSelector -> [PackageName]
targetPkgNames ([PackageSpecifier UnresolvedSourcePackage]
 -> TargetSelector -> [PackageName])
-> [PackageSpecifier UnresolvedSourcePackage]
-> TargetSelector
-> [PackageName]
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
baseCtx) [TargetSelector]
targetSelectors
  ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector],
 ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector],
      ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
pkgSpecs, [TargetSelector]
targetSelectors, ProjectConfig
config)
  where
    reducedVerbosity :: Verbosity
reducedVerbosity = Verbosity -> Verbosity
lessVerbose Verbosity
verbosity

    -- We take the targets and try to parse them as package ids (with name and version).
    -- The ones who don't parse will have to be resolved in the project context.
    ([FilePath]
unresolvedTargetStrings, [PackageIdentifier]
parsedPackageIds) =
      [Either FilePath PackageIdentifier]
-> ([FilePath], [PackageIdentifier])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either FilePath PackageIdentifier]
 -> ([FilePath], [PackageIdentifier]))
-> [Either FilePath PackageIdentifier]
-> ([FilePath], [PackageIdentifier])
forall a b. (a -> b) -> a -> b
$
        ((FilePath -> Either FilePath PackageIdentifier)
 -> [FilePath] -> [Either FilePath PackageIdentifier])
-> [FilePath]
-> (FilePath -> Either FilePath PackageIdentifier)
-> [Either FilePath PackageIdentifier]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> Either FilePath PackageIdentifier)
-> [FilePath] -> [Either FilePath PackageIdentifier]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath]
targetStrings ((FilePath -> Either FilePath PackageIdentifier)
 -> [Either FilePath PackageIdentifier])
-> (FilePath -> Either FilePath PackageIdentifier)
-> [Either FilePath PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ \FilePath
s ->
          case FilePath -> Either FilePath PackageIdentifier
forall a. Parsec a => FilePath -> Either FilePath a
eitherParsec FilePath
s of
            Right pkgId :: PackageIdentifier
pkgId@PackageIdentifier{Version
pkgVersion :: Version
pkgVersion :: PackageIdentifier -> Version
pkgVersion}
              | Version
pkgVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
nullVersion ->
                  PackageIdentifier -> Either FilePath PackageIdentifier
forall a. a -> Either FilePath a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
pkgId
            Either FilePath PackageIdentifier
_ -> FilePath -> Either FilePath PackageIdentifier
forall a b. a -> Either a b
Left FilePath
s

    -- For each packageId, we output a NamedPackage specifier (i.e. a package only known by
    -- its name) and a target selector.
    ([PackageSpecifier pkg]
parsedPkgSpecs, [TargetSelector]
parsedTargets) =
      [(PackageSpecifier pkg, TargetSelector)]
-> ([PackageSpecifier pkg], [TargetSelector])
forall a b. [(a, b)] -> ([a], [b])
unzip
        [ (PackageIdentifier -> PackageSpecifier pkg
forall pkg. PackageIdentifier -> PackageSpecifier pkg
mkNamedPackage PackageIdentifier
pkgId, PackageName -> Maybe ComponentKindFilter -> TargetSelector
TargetPackageNamed (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId) Maybe ComponentKindFilter
targetFilter)
        | PackageIdentifier
pkgId <- [PackageIdentifier]
parsedPackageIds
        ]

    targetFilter :: Maybe ComponentKindFilter
targetFilter = if Bool
installLibs then ComponentKindFilter -> Maybe ComponentKindFilter
forall a. a -> Maybe a
Just ComponentKindFilter
LibKind else ComponentKindFilter -> Maybe ComponentKindFilter
forall a. a -> Maybe a
Just ComponentKindFilter
ExeKind

resolveTargetSelectorsInProjectBaseContext
  :: Verbosity
  -> ProjectBaseContext
  -> [String]
  -> Maybe ComponentKindFilter
  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
resolveTargetSelectorsInProjectBaseContext :: Verbosity
-> ProjectBaseContext
-> [FilePath]
-> Maybe ComponentKindFilter
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
resolveTargetSelectorsInProjectBaseContext Verbosity
verbosity ProjectBaseContext
baseCtx [FilePath]
targetStrings Maybe ComponentKindFilter
targetFilter = do
  let reducedVerbosity :: Verbosity
reducedVerbosity = Verbosity -> Verbosity
lessVerbose Verbosity
verbosity

  SourcePackageDb
sourcePkgDb <-
    Verbosity
-> BuildTimeSettings
-> (RepoContext -> IO SourcePackageDb)
-> IO SourcePackageDb
forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext
      Verbosity
reducedVerbosity
      (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
      (Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity)

  [TargetSelector]
targetSelectors <-
    [PackageSpecifier UnresolvedSourcePackage]
-> Maybe ComponentKindFilter
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
baseCtx) Maybe ComponentKindFilter
forall a. Maybe a
Nothing [FilePath]
targetStrings
      IO (Either [TargetSelectorProblem] [TargetSelector])
-> (Either [TargetSelectorProblem] [TargetSelector]
    -> IO [TargetSelector])
-> IO [TargetSelector]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left [TargetSelectorProblem]
problems -> Verbosity -> [TargetSelectorProblem] -> IO [TargetSelector]
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity [TargetSelectorProblem]
problems
        Right [TargetSelector]
ts -> [TargetSelector] -> IO [TargetSelector]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [TargetSelector]
ts

  Verbosity
-> Verbosity
-> SourcePackageDb
-> [TargetSelector]
-> DistDirLayout
-> ProjectBaseContext
-> Maybe ComponentKindFilter
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors
    Verbosity
verbosity
    Verbosity
reducedVerbosity
    SourcePackageDb
sourcePkgDb
    [TargetSelector]
targetSelectors
    (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx)
    ProjectBaseContext
baseCtx
    Maybe ComponentKindFilter
targetFilter

withoutProject
  :: Verbosity
  -> ProjectConfig
  -> [String]
  -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
withoutProject :: Verbosity
-> ProjectConfig
-> [FilePath]
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
withoutProject Verbosity
verbosity ProjectConfig
globalConfig [FilePath]
targetStrings = do
  [WithoutProjectTargetSelector]
tss <- (FilePath -> IO WithoutProjectTargetSelector)
-> [FilePath] -> IO [WithoutProjectTargetSelector]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Verbosity -> FilePath -> IO WithoutProjectTargetSelector
parseWithoutProjectTargetSelector Verbosity
verbosity) [FilePath]
targetStrings
  let
    ProjectConfigBuildOnly
      { Flag FilePath
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigLogsDir :: Flag FilePath
projectConfigLogsDir
      } = ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
globalConfig

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

    mlogsDir :: Maybe FilePath
mlogsDir = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigLogsDir
    mstoreDir :: Maybe FilePath
mstoreDir = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigStoreDir

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

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

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

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

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

  -- Apply the local configuration (e.g. cli flags) to all direct targets of install command,
  -- see note in 'installAction'
  let config :: ProjectConfig
config = ProjectConfig -> [PackageName] -> ProjectConfig
addLocalConfigToPkgs ProjectConfig
globalConfig ((WithoutProjectTargetSelector -> [PackageName])
-> [WithoutProjectTargetSelector] -> [PackageName]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WithoutProjectTargetSelector -> [PackageName]
woPackageNames [WithoutProjectTargetSelector]
tss)
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
 [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
packageSpecifiers, [URI]
uris, [TargetSelector]
packageTargets, ProjectConfig
config)

addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig
addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig
addLocalConfigToPkgs ProjectConfig
config [PackageName]
pkgs =
  ProjectConfig
config
    { projectConfigSpecificPackage =
        projectConfigSpecificPackage config
          <> MapMappend (Map.fromList targetPackageConfigs)
    }
  where
    localConfig :: PackageConfig
localConfig = ProjectConfig -> PackageConfig
projectConfigLocalPackages ProjectConfig
config
    targetPackageConfigs :: [(PackageName, PackageConfig)]
targetPackageConfigs = (PackageName -> (PackageName, PackageConfig))
-> [PackageName] -> [(PackageName, PackageConfig)]
forall a b. (a -> b) -> [a] -> [b]
map (,PackageConfig
localConfig) [PackageName]
pkgs

targetPkgNames
  :: [PackageSpecifier UnresolvedSourcePackage]
  -- ^ The local packages, to resolve 'TargetAllPackages' selectors
  -> TargetSelector
  -> [PackageName]
targetPkgNames :: [PackageSpecifier UnresolvedSourcePackage]
-> TargetSelector -> [PackageName]
targetPkgNames [PackageSpecifier UnresolvedSourcePackage]
localPkgs = \case
  TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
pkgIds Maybe ComponentKindFilter
_ -> (PackageIdentifier -> PackageName)
-> [PackageIdentifier] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageIdentifier -> PackageName
pkgName [PackageIdentifier]
pkgIds
  TargetPackageNamed PackageName
name Maybe ComponentKindFilter
_ -> [PackageName
name]
  TargetAllPackages Maybe ComponentKindFilter
_ -> (PackageSpecifier UnresolvedSourcePackage -> PackageName)
-> [PackageSpecifier UnresolvedSourcePackage] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget [PackageSpecifier UnresolvedSourcePackage]
localPkgs
  -- Note how the target may select a component only, but we will always apply
  -- the local flags to the whole package in which that component is contained.
  -- The reason is that our finest level of configuration is per-package, so
  -- there is no interface to configure options to a component only. It is not
  -- trivial to say whether we could indeed support per-component configuration
  -- because of legacy packages which we may always have to build whole.
  TargetComponent PackageIdentifier
pkgId ComponentName
_ SubComponentTarget
_ -> [PackageIdentifier -> PackageName
pkgName PackageIdentifier
pkgId]
  TargetComponentUnknown PackageName
name Either UnqualComponentName ComponentName
_ SubComponentTarget
_ -> [PackageName
name]

-- | Verify that invalid config options were not passed to the install command.
--
-- If an invalid configuration is found the command will @dieWithException@.
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
configFlags = do
  -- We never try to build tests/benchmarks for remote packages.
  -- So we set them as disabled by default and error if they are explicitly
  -- enabled.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
ConfigTests
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
ConfigBenchmarks

-- | Apply the given 'ClientInstallFlags' on top of one coming from the global configuration.
getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags :: Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
existingClientInstallFlags = do
  let configFileFlag :: Flag FilePath
configFileFlag = GlobalFlags -> Flag FilePath
globalConfigFile GlobalFlags
globalFlags
  SavedConfig
savedConfig <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
  ClientInstallFlags -> IO ClientInstallFlags
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientInstallFlags -> IO ClientInstallFlags)
-> ClientInstallFlags -> IO ClientInstallFlags
forall a b. (a -> b) -> a -> b
$ SavedConfig -> ClientInstallFlags
savedClientInstallFlags SavedConfig
savedConfig ClientInstallFlags -> ClientInstallFlags -> ClientInstallFlags
forall a. Monoid a => a -> a -> a
`mappend` ClientInstallFlags
existingClientInstallFlags

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

    let
      planMap :: Map
  UnitId
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
planMap = ElaboratedInstallPlan
-> Map
     UnitId
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
InstallPlan.toMap ElaboratedInstallPlan
elaboratedPlan

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

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

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

      localTargets :: [TargetSelector]
localTargets = (UnitId -> TargetSelector) -> [UnitId] -> [TargetSelector]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> TargetSelector
gatherTargets (TargetsMap -> [UnitId]
forall k a. Map k a -> [k]
Map.keys TargetsMap
targetsMap)

      hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
      hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs = [PackageName
-> [PackageProperty] -> PackageSpecifier UnresolvedSourcePackage
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pn [] | PackageName
pn <- [PackageName]
hackageNames]

      hackageTargets :: [TargetSelector]
      hackageTargets :: [TargetSelector]
hackageTargets = [PackageName -> Maybe ComponentKindFilter -> TargetSelector
TargetPackageNamed PackageName
pn Maybe ComponentKindFilter
targetFilter | PackageName
pn <- [PackageName]
hackageNames]

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TargetsMap -> Bool
forall k a. Map k a -> Bool
Map.null TargetsMap
targetsMap) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [PackageSpecifier UnresolvedSourcePackage]
-> (PackageSpecifier UnresolvedSourcePackage -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
baseCtx) ((PackageSpecifier UnresolvedSourcePackage -> IO ()) -> IO ())
-> (PackageSpecifier UnresolvedSourcePackage -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
      SpecificSourcePackage UnresolvedSourcePackage
pkg ->
        Verbosity
-> FilePath
-> OutputFormat
-> FilePath
-> UnresolvedSourcePackage
-> IO ()
packageToSdist
          Verbosity
verbosity
          (DistDirLayout -> FilePath
distProjectRootDirectory DistDirLayout
distDirLayout)
          OutputFormat
TarGzArchive
          (DistDirLayout -> PackageIdentifier -> FilePath
distSdistFile DistDirLayout
distDirLayout (UnresolvedSourcePackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId UnresolvedSourcePackage
pkg))
          UnresolvedSourcePackage
pkg
      NamedPackage PackageName
_ [PackageProperty]
_ ->
        -- This may happen if 'extra-packages' are listed in the project file.
        -- We don't need to do extra work for NamedPackages since they will be
        -- fetched from Hackage rather than locally 'sdistize'-d. Note how,
        -- below, we already return the local 'sdistize'-d packages together
        -- with the 'hackagePkgs' (which are 'NamedPackage's), and that
        -- 'sdistize' is a no-op for 'NamedPackages', meaning the
        -- 'NamedPackage's in 'localPkgs' will be treated just like
        -- 'hackagePkgs' as they should.
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

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

      -- report incorrect case for known package.
      [TargetProblem Void] -> (TargetProblem Void -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TargetProblem Void]
errs' ((TargetProblem Void -> IO ()) -> IO ())
-> (TargetProblem Void -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \case
        TargetNotInProject PackageName
hn ->
          case PackageIndex UnresolvedSourcePackage
-> FilePath -> [(PackageName, [UnresolvedSourcePackage])]
forall pkg. PackageIndex pkg -> FilePath -> [(PackageName, [pkg])]
searchByName (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
pkgDb) (PackageName -> FilePath
unPackageName PackageName
hn) of
            [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [(PackageName, [UnresolvedSourcePackage])]
xs ->
              Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> CabalInstallException
UnknownPackage (PackageName -> FilePath
unPackageName PackageName
hn) ((FilePath
"- " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> ((PackageName, [UnresolvedSourcePackage]) -> FilePath)
-> (PackageName, [UnresolvedSourcePackage])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName (PackageName -> FilePath)
-> ((PackageName, [UnresolvedSourcePackage]) -> PackageName)
-> (PackageName, [UnresolvedSourcePackage])
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, [UnresolvedSourcePackage]) -> PackageName
forall a b. (a, b) -> a
fst ((PackageName, [UnresolvedSourcePackage]) -> FilePath)
-> [(PackageName, [UnresolvedSourcePackage])] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
        TargetProblem Void
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

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

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

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

    (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
prunedElaboratedPlan, TargetsMap
targets)

-- | From an install configuration, prepare the record needed by actions that
-- will either check if an install of a single executable is possible or
-- actually perform its installation.
prepareExeInstall :: InstallCfg -> IO InstallExe
prepareExeInstall :: InstallCfg -> IO InstallExe
prepareExeInstall
  InstallCfg{Verbosity
verbosity :: InstallCfg -> Verbosity
verbosity :: Verbosity
verbosity, ProjectBaseContext
baseCtx :: InstallCfg -> ProjectBaseContext
baseCtx :: ProjectBaseContext
baseCtx, ProjectBuildContext
buildCtx :: InstallCfg -> ProjectBuildContext
buildCtx :: ProjectBuildContext
buildCtx, Platform
platform :: InstallCfg -> Platform
platform :: Platform
platform, Compiler
compiler :: InstallCfg -> Compiler
compiler :: Compiler
compiler, ConfigFlags
installConfigFlags :: InstallCfg -> ConfigFlags
installConfigFlags :: ConfigFlags
installConfigFlags, ClientInstallFlags
installClientFlags :: InstallCfg -> ClientInstallFlags
installClientFlags :: ClientInstallFlags
installClientFlags} = do
    FilePath
installPath <- IO FilePath
defaultInstallPath
    let storeDirLayout :: StoreDirLayout
storeDirLayout = CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout (CabalDirLayout -> StoreDirLayout)
-> CabalDirLayout -> StoreDirLayout
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx

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

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

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

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

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

    -- This is in IO as we will make environment checks, to decide which install
    -- method is best.
    let defaultMethod :: IO InstallMethod
        defaultMethod :: IO InstallMethod
defaultMethod
          -- Try symlinking in temporary directory, if it works default to
          -- symlinking even on windows.
          | OS
buildOS OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
Windows = do
              Bool
symlinks <- Verbosity -> IO Bool
trySymlink Verbosity
verbosity
              InstallMethod -> IO InstallMethod
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallMethod -> IO InstallMethod)
-> InstallMethod -> IO InstallMethod
forall a b. (a -> b) -> a -> b
$ if Bool
symlinks then InstallMethod
InstallMethodSymlink else InstallMethod
InstallMethodCopy
          | Bool
otherwise = InstallMethod -> IO InstallMethod
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstallMethod
InstallMethodSymlink

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

    InstallExe -> IO InstallExe
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstallExe -> IO InstallExe) -> InstallExe -> IO InstallExe
forall a b. (a -> b) -> a -> b
$ InstallMethod
-> FilePath
-> (UnitId -> FilePath)
-> (UnqualComponentName -> FilePath)
-> (UnqualComponentName -> FilePath)
-> InstallExe
InstallExe InstallMethod
installMethod FilePath
installdir UnitId -> FilePath
mkUnitBinDir UnqualComponentName -> FilePath
mkExeName UnqualComponentName -> FilePath
mkFinalExeName

-- | Install any built library by adding it to the default ghc environment
installLibraries
  :: Verbosity
  -> ProjectBuildContext
  -> PI.PackageIndex InstalledPackageInfo
  -> Compiler
  -> PackageDBStackCWD
  -> FilePath
  -- ^ Environment file
  -> [GhcEnvironmentFileEntry FilePath]
  -> Bool
  -- ^ Whether we need to show a warning (i.e. we created a new environment
  --   file, and the user did not use --package-env)
  -> IO ()
installLibraries :: Verbosity
-> ProjectBuildContext
-> InstalledPackageIndex
-> Compiler
-> PackageDBStackCWD
-> FilePath
-> [GhcEnvironmentFileEntry FilePath]
-> Bool
-> IO ()
installLibraries
  Verbosity
verbosity
  ProjectBuildContext
buildCtx
  InstalledPackageIndex
installedIndex
  Compiler
compiler
  PackageDBStackCWD
packageDbs'
  FilePath
envFile
  [GhcEnvironmentFileEntry FilePath]
envEntries
  Bool
showWarning = do
    if GhcImplInfo -> Bool
supportsPkgEnvFiles (GhcImplInfo -> Bool) -> GhcImplInfo -> Bool
forall a b. (a -> b) -> a -> b
$ Compiler -> GhcImplInfo
getImplInfo Compiler
compiler
      then do
        let validDb :: PackageDBCWD -> IO Bool
validDb (SpecificPackageDB FilePath
fp) = FilePath -> IO Bool
doesPathExist FilePath
fp
            validDb PackageDBCWD
_ = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        -- if a user "installs" a global package and no existing cabal db exists, none will be created.
        -- this ensures we don't add the "phantom" path to the file.
        PackageDBStackCWD
packageDbs <- (PackageDBCWD -> IO Bool)
-> PackageDBStackCWD -> IO PackageDBStackCWD
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM PackageDBCWD -> IO Bool
validDb PackageDBStackCWD
packageDbs'
        let
          getLatest :: PackageName -> [InstalledPackageInfo]
getLatest =
            ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (Maybe InstalledPackageInfo -> [InstalledPackageInfo]
forall a. Maybe a -> [a]
maybeToList (Maybe InstalledPackageInfo -> [InstalledPackageInfo])
-> ((Version, [InstalledPackageInfo])
    -> Maybe InstalledPackageInfo)
-> (Version, [InstalledPackageInfo])
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> Maybe InstalledPackageInfo
forall a. [a] -> Maybe a
safeHead ([InstalledPackageInfo] -> Maybe InstalledPackageInfo)
-> ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> (Version, [InstalledPackageInfo])
-> Maybe InstalledPackageInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd)
              ([(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [(Version, [InstalledPackageInfo])]
-> [(Version, [InstalledPackageInfo])]
forall a. Int -> [a] -> [a]
take Int
1
              ([(Version, [InstalledPackageInfo])]
 -> [(Version, [InstalledPackageInfo])])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [(Version, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, [InstalledPackageInfo])
 -> (Version, [InstalledPackageInfo]) -> Ordering)
-> [(Version, [InstalledPackageInfo])]
-> [(Version, [InstalledPackageInfo])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Version, [InstalledPackageInfo]) -> Down Version)
-> (Version, [InstalledPackageInfo])
-> (Version, [InstalledPackageInfo])
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Version -> Down Version
forall a. a -> Down a
Down (Version -> Down Version)
-> ((Version, [InstalledPackageInfo]) -> Version)
-> (Version, [InstalledPackageInfo])
-> Down Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> Version
forall a b. (a, b) -> a
fst))
              ([(Version, [InstalledPackageInfo])]
 -> [(Version, [InstalledPackageInfo])])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [(Version, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PI.lookupPackageName InstalledPackageIndex
installedIndex
          globalLatest :: [InstalledPackageInfo]
globalLatest = [[InstalledPackageInfo]] -> [InstalledPackageInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PackageName -> [InstalledPackageInfo]
getLatest (PackageName -> [InstalledPackageInfo])
-> [PackageName] -> [[InstalledPackageInfo]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
globalPackages)
          globalEntries :: [GhcEnvironmentFileEntry fp]
globalEntries = UnitId -> GhcEnvironmentFileEntry fp
forall fp. UnitId -> GhcEnvironmentFileEntry fp
GhcEnvFilePackageId (UnitId -> GhcEnvironmentFileEntry fp)
-> (InstalledPackageInfo -> UnitId)
-> InstalledPackageInfo
-> GhcEnvironmentFileEntry fp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
installedUnitId (InstalledPackageInfo -> GhcEnvironmentFileEntry fp)
-> [InstalledPackageInfo] -> [GhcEnvironmentFileEntry fp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstalledPackageInfo]
globalLatest
          baseEntries :: [GhcEnvironmentFileEntry FilePath]
baseEntries =
            GhcEnvironmentFileEntry FilePath
forall fp. GhcEnvironmentFileEntry fp
GhcEnvFileClearPackageDbStack GhcEnvironmentFileEntry FilePath
-> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a. a -> [a] -> [a]
: (PackageDBCWD -> GhcEnvironmentFileEntry FilePath)
-> PackageDBStackCWD -> [GhcEnvironmentFileEntry FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDBCWD -> GhcEnvironmentFileEntry FilePath
forall fp. PackageDBX fp -> GhcEnvironmentFileEntry fp
GhcEnvFilePackageDb PackageDBStackCWD
packageDbs
          pkgEntries :: [GhcEnvironmentFileEntry FilePath]
pkgEntries =
            [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a. Ord a => [a] -> [a]
ordNub ([GhcEnvironmentFileEntry FilePath]
 -> [GhcEnvironmentFileEntry FilePath])
-> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a b. (a -> b) -> a -> b
$
              [GhcEnvironmentFileEntry FilePath]
forall {fp}. [GhcEnvironmentFileEntry fp]
globalEntries
                [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry FilePath]
envEntries
                [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a. [a] -> [a] -> [a]
++ TargetsMap -> [GhcEnvironmentFileEntry FilePath]
entriesForLibraryComponents (ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx)
          contents' :: FilePath
contents' = [GhcEnvironmentFileEntry FilePath] -> FilePath
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry FilePath]
baseEntries [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry FilePath]
pkgEntries)
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
envFile)
        FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
envFile (FilePath -> ByteString
BS.pack FilePath
contents')
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
showWarning (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
            FilePath
"The libraries were installed by creating a global GHC environment file at:\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
envFile
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"The presence of such an environment file is likely to confuse or break other "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"tools because it changes GHC's behaviour: it changes the default package set in "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"ghc and ghci from its normal value (which is \"all boot libraries\"). GHC "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"environment files are little-used and often not tested for.\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Furthermore, management of these environment files is still more difficult than "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"it could be; see e.g. https://github.com/haskell/cabal/issues/6481 .\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Double-check that creating a global GHC environment file is really what you "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"wanted! You can limit the effects of the environment file by creating it in a "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"specific directory using the --package-env flag. For example, use:\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"cabal install --lib <packages...> --package-env .\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"to create the file in the current directory."
      else
        Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
          FilePath
"The current compiler doesn't support safely installing libraries, "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"so only executables will be available. (Library installation is "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"supported on GHC 8.0+ only)"

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

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

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

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

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

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

-- | Disables program prefix and suffix, in order to get the /canonical/
-- executable name in the store and thus:
--
-- * avoid making the package hash depend on these options and needless rebuild;
-- * provide the correct executable path to the install methods (copy, symlink).
ignoreProgramAffixes :: ConfigFlags -> ConfigFlags
ignoreProgramAffixes :: ConfigFlags -> ConfigFlags
ignoreProgramAffixes ConfigFlags
configFlags =
  ConfigFlags
configFlags
    { configProgPrefix = NoFlag
    , configProgSuffix = NoFlag
    }

-- | Prepares a record containing the information needed to either symlink or
-- copy an executable.
symlink :: OverwritePolicy -> InstallExe -> UnitId -> UnqualComponentName -> Symlink
symlink :: OverwritePolicy
-> InstallExe -> UnitId -> UnqualComponentName -> Symlink
symlink
  OverwritePolicy
overwritePolicy
  InstallExe{FilePath
installDir :: InstallExe -> FilePath
installDir :: FilePath
installDir, UnitId -> FilePath
mkSourceBinDir :: InstallExe -> UnitId -> FilePath
mkSourceBinDir :: UnitId -> FilePath
mkSourceBinDir, UnqualComponentName -> FilePath
mkExeName :: InstallExe -> UnqualComponentName -> FilePath
mkExeName :: UnqualComponentName -> FilePath
mkExeName, UnqualComponentName -> FilePath
mkFinalExeName :: InstallExe -> UnqualComponentName -> FilePath
mkFinalExeName :: UnqualComponentName -> FilePath
mkFinalExeName}
  UnitId
unit
  UnqualComponentName
exe =
    OverwritePolicy
-> FilePath -> FilePath -> FilePath -> FilePath -> Symlink
Symlink
      OverwritePolicy
overwritePolicy
      FilePath
installDir
      (UnitId -> FilePath
mkSourceBinDir UnitId
unit)
      (UnqualComponentName -> FilePath
mkFinalExeName UnqualComponentName
exe)
      (UnqualComponentName -> FilePath
mkExeName UnqualComponentName
exe)

-- |
-- -- * When 'InstallCheckOnly', warn if install would fail overwrite policy
--      checks but don't install anything.
-- -- * When 'InstallCheckInstall', try to symlink or copy every package exe
--      from the store to a given location. When not permitted by the overwrite
--      policy, stop with a message.
installCheckUnitExes :: InstallCheck -> InstallAction
installCheckUnitExes :: InstallCheck -> InstallAction
installCheckUnitExes
  InstallCheck
installCheck
  Verbosity
verbosity
  OverwritePolicy
overwritePolicy
  installExe :: InstallExe
installExe@InstallExe{InstallMethod
installMethod :: InstallExe -> InstallMethod
installMethod :: InstallMethod
installMethod, FilePath
installDir :: InstallExe -> FilePath
installDir :: FilePath
installDir, UnitId -> FilePath
mkSourceBinDir :: InstallExe -> UnitId -> FilePath
mkSourceBinDir :: UnitId -> FilePath
mkSourceBinDir, UnqualComponentName -> FilePath
mkExeName :: InstallExe -> UnqualComponentName -> FilePath
mkExeName :: UnqualComponentName -> FilePath
mkExeName, UnqualComponentName -> FilePath
mkFinalExeName :: InstallExe -> UnqualComponentName -> FilePath
mkFinalExeName :: UnqualComponentName -> FilePath
mkFinalExeName}
  (UnitId
unit, [(ComponentTarget, NonEmpty TargetSelector)]
components) = do
    [Bool]
symlinkables :: [Bool] <- (UnqualComponentName -> IO Bool)
-> [UnqualComponentName] -> IO [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Symlink -> IO Bool
symlinkableBinary (Symlink -> IO Bool)
-> (UnqualComponentName -> Symlink)
-> UnqualComponentName
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OverwritePolicy
-> InstallExe -> UnitId -> UnqualComponentName -> Symlink
symlink OverwritePolicy
overwritePolicy InstallExe
installExe UnitId
unit) [UnqualComponentName]
exes
    case InstallCheck
installCheck of
      InstallCheck
InstallCheckOnly -> ((Bool, UnqualComponentName) -> IO ())
-> [(Bool, UnqualComponentName)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool, UnqualComponentName) -> IO ()
warnAbout ([Bool] -> [UnqualComponentName] -> [(Bool, UnqualComponentName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
symlinkables [UnqualComponentName]
exes)
      InstallCheck
InstallCheckInstall ->
        if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
symlinkables
          then (UnqualComponentName -> IO ()) -> [UnqualComponentName] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ UnqualComponentName -> IO ()
installAndWarn [UnqualComponentName]
exes
          else ((Bool, UnqualComponentName) -> IO ())
-> [(Bool, UnqualComponentName)] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool, UnqualComponentName) -> IO ()
warnAbout ([Bool] -> [UnqualComponentName] -> [(Bool, UnqualComponentName)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
symlinkables [UnqualComponentName]
exes)
    where
      exes :: [UnqualComponentName]
exes = [Maybe UnqualComponentName] -> [UnqualComponentName]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UnqualComponentName] -> [UnqualComponentName])
-> [Maybe UnqualComponentName] -> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ (ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget -> Maybe UnqualComponentName)
-> ((ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget)
-> (ComponentTarget, NonEmpty TargetSelector)
-> Maybe UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget
forall a b. (a, b) -> a
fst) ((ComponentTarget, NonEmpty TargetSelector)
 -> Maybe UnqualComponentName)
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [Maybe UnqualComponentName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ComponentTarget, NonEmpty TargetSelector)]
components
      exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just UnqualComponentName
exe
      exeMaybe ComponentTarget
_ = Maybe UnqualComponentName
forall a. Maybe a
Nothing

      warnAbout :: (Bool, UnqualComponentName) -> IO ()
warnAbout (Bool
True, UnqualComponentName
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      warnAbout (Bool
False, UnqualComponentName
exe) = Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
InstallUnitExes (FilePath -> UnqualComponentName -> FilePath
errorMessage FilePath
installDir UnqualComponentName
exe)

      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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
InstallUnitExes (FilePath -> UnqualComponentName -> FilePath
errorMessage FilePath
installDir UnqualComponentName
exe)

      errorMessage :: FilePath -> UnqualComponentName -> FilePath
errorMessage FilePath
installdir UnqualComponentName
exe = case OverwritePolicy
overwritePolicy of
        OverwritePolicy
NeverOverwrite ->
          FilePath
"Path '"
            FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath
installdir FilePath -> FilePath -> FilePath
</> UnqualComponentName -> FilePath
mkFinalExeName UnqualComponentName
exe)
            FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' already exists. "
            FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"Use --overwrite-policy=always to overwrite."
        -- This shouldn't even be possible, but we keep it in case symlinking or
        -- copying logic changes.
        OverwritePolicy
_ ->
          case InstallMethod
installMethod of
            InstallMethod
InstallMethodSymlink -> FilePath
"Symlinking"
            InstallMethod
InstallMethodCopy -> FilePath
"Copying" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' failed."

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

-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry FilePath]
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry FilePath]
entriesForLibraryComponents = (UnitId
 -> [(ComponentTarget, NonEmpty TargetSelector)]
 -> [GhcEnvironmentFileEntry FilePath]
 -> [GhcEnvironmentFileEntry FilePath])
-> [GhcEnvironmentFileEntry FilePath]
-> TargetsMap
-> [GhcEnvironmentFileEntry FilePath]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' (\UnitId
k [(ComponentTarget, NonEmpty TargetSelector)]
v -> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall a. Monoid a => a -> a -> a
mappend (UnitId
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GhcEnvironmentFileEntry FilePath]
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 FilePath]
    go :: UnitId
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GhcEnvironmentFileEntry FilePath]
go UnitId
unitId [(ComponentTarget, NonEmpty TargetSelector)]
targets
      | ((ComponentTarget, NonEmpty TargetSelector) -> Bool)
-> [(ComponentTarget, NonEmpty TargetSelector)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ComponentTarget, NonEmpty TargetSelector) -> Bool
hasLib [(ComponentTarget, NonEmpty TargetSelector)]
targets = [UnitId -> GhcEnvironmentFileEntry FilePath
forall fp. UnitId -> GhcEnvironmentFileEntry fp
GhcEnvFilePackageId UnitId
unitId]
      | Bool
otherwise = []

-- | Gets the file path to the request environment file. The @Bool@ is @True@
-- if we got an explicit instruction using @--package-env@, @False@ if we used
-- the default.
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO (Bool, FilePath)
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO (Bool, FilePath)
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion = do
  FilePath
appDir <- IO FilePath
getGhcAppDir
  case Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe (ClientInstallFlags -> Flag FilePath
cinstEnvironmentPath ClientInstallFlags
clientInstallFlags) of
    Just FilePath
spec
      -- Is spec a bare word without any "pathy" content, then it refers to
      -- a named global environment.
      | FilePath -> FilePath
takeBaseName FilePath
spec FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
spec ->
          (Bool, FilePath) -> IO (Bool, FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, 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
            then -- If spec is a directory, then make an ambient environment inside
            -- that directory.
              (Bool, FilePath) -> IO (Bool, FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, FilePath -> Platform -> Version -> FilePath
getLocalEnv FilePath
spec' Platform
platform Version
compilerVersion)
            else -- Otherwise, treat it like a literal file path.
              (Bool, FilePath) -> IO (Bool, FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, FilePath
spec')
    Maybe FilePath
Nothing ->
      (Bool, FilePath) -> IO (Bool, FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, FilePath -> Platform -> Version -> FilePath -> FilePath
getGlobalEnv FilePath
appDir Platform
platform Version
compilerVersion FilePath
"default")

-- | Returns the list of @GhcEnvFilePackageId@ values already existing in the
--   environment being operated on. The @Bool@ is @True@ if we took settings
--   from an existing file, @False@ otherwise.
getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO (Bool, [GhcEnvironmentFileEntry FilePath])
getExistingEnvEntries :: Verbosity
-> CompilerFlavor
-> Bool
-> FilePath
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile = do
  Bool
envFileExists <- FilePath -> IO Bool
doesFileExist FilePath
envFile
  (Bool
usedExisting, [GhcEnvironmentFileEntry FilePath]
allEntries) <-
    if (CompilerFlavor
compilerFlavor CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC Bool -> Bool -> Bool
|| CompilerFlavor
compilerFlavor CompilerFlavor -> CompilerFlavor -> Bool
forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHCJS)
      Bool -> Bool -> Bool
&& Bool
supportsPkgEnvFiles
      Bool -> Bool -> Bool
&& Bool
envFileExists
      then IO (Bool, [GhcEnvironmentFileEntry FilePath])
-> (ParseErrorExc -> IO (Bool, [GhcEnvironmentFileEntry FilePath]))
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch ((Bool
True,) ([GhcEnvironmentFileEntry FilePath]
 -> (Bool, [GhcEnvironmentFileEntry FilePath]))
-> IO [GhcEnvironmentFileEntry FilePath]
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [GhcEnvironmentFileEntry FilePath]
readGhcEnvironmentFile FilePath
envFile) ((ParseErrorExc -> IO (Bool, [GhcEnvironmentFileEntry FilePath]))
 -> IO (Bool, [GhcEnvironmentFileEntry FilePath]))
-> (ParseErrorExc -> IO (Bool, [GhcEnvironmentFileEntry FilePath]))
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall a b. (a -> b) -> a -> b
$ \(ParseErrorExc
_ :: ParseErrorExc) ->
        Verbosity -> FilePath -> IO ()
warn
          Verbosity
verbosity
          ( FilePath
"The environment file "
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
envFile
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is unparsable. Libraries cannot be installed."
          )
          IO ()
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, [GhcEnvironmentFileEntry FilePath])
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
      else (Bool, [GhcEnvironmentFileEntry FilePath])
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
  (Bool, [GhcEnvironmentFileEntry FilePath])
-> IO (Bool, [GhcEnvironmentFileEntry FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
usedExisting, [GhcEnvironmentFileEntry FilePath]
-> [GhcEnvironmentFileEntry FilePath]
forall {fp}.
[GhcEnvironmentFileEntry fp] -> [GhcEnvironmentFileEntry fp]
filterEnvEntries [GhcEnvironmentFileEntry FilePath]
allEntries)
  where
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries :: [GhcEnvironmentFileEntry fp] -> [GhcEnvironmentFileEntry fp]
filterEnvEntries = (GhcEnvironmentFileEntry fp -> Bool)
-> [GhcEnvironmentFileEntry fp] -> [GhcEnvironmentFileEntry fp]
forall a. (a -> Bool) -> [a] -> [a]
filter ((GhcEnvironmentFileEntry fp -> Bool)
 -> [GhcEnvironmentFileEntry fp] -> [GhcEnvironmentFileEntry fp])
-> (GhcEnvironmentFileEntry fp -> Bool)
-> [GhcEnvironmentFileEntry fp]
-> [GhcEnvironmentFileEntry fp]
forall a b. (a -> b) -> a -> b
$ \case
      GhcEnvFilePackageId UnitId
_ -> Bool
True
      GhcEnvironmentFileEntry fp
_ -> Bool
False

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

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

getPackageDbStack
  :: Compiler
  -> Flag FilePath
  -> Flag FilePath
  -> [Maybe PackageDBCWD]
  -> IO PackageDBStackCWD
getPackageDbStack :: Compiler
-> Flag FilePath
-> Flag FilePath
-> [Maybe PackageDBCWD]
-> IO PackageDBStackCWD
getPackageDbStack Compiler
compiler Flag FilePath
storeDirFlag Flag FilePath
logsDirFlag [Maybe PackageDBCWD]
packageDbs = do
  Maybe FilePath
mstoreDir <- (FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse FilePath -> IO FilePath
makeAbsolute (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
storeDirFlag
  let
    mlogsDir :: Maybe FilePath
mlogsDir = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
logsDirFlag
  CabalDirLayout
cabalLayout <- Maybe FilePath -> Maybe FilePath -> IO CabalDirLayout
mkCabalDirLayout Maybe FilePath
mstoreDir Maybe FilePath
mlogsDir
  PackageDBStackCWD -> IO PackageDBStackCWD
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDBStackCWD -> IO PackageDBStackCWD)
-> PackageDBStackCWD -> IO PackageDBStackCWD
forall a b. (a -> b) -> a -> b
$ StoreDirLayout
-> Compiler -> [Maybe PackageDBCWD] -> PackageDBStackCWD
storePackageDBStack (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalLayout) Compiler
compiler [Maybe PackageDBCWD]
packageDbs

-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
selectPackageTargets
  :: TargetSelector
  -> [AvailableTarget k]
  -> Either TargetProblem' [k]
selectPackageTargets :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets
  -- If there are any buildable targets then we select those
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable) =
      [k] -> Either (TargetProblem Void) [k]
forall a b. b -> Either a b
Right [k]
targetsBuildable
  -- If there are targets but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets) =
      TargetProblem Void -> Either (TargetProblem Void) [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem Void
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')
  -- If there are no targets at all then we report that
  | Bool
otherwise =
      TargetProblem Void -> Either (TargetProblem Void) [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem Void
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets' = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    targetsBuildable :: [k]
targetsBuildable =
      (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith
        (TargetSelector -> TargetRequested -> Bool
buildable TargetSelector
targetSelector)
        [AvailableTarget k]
targets

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

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

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

reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies :: forall a. Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies Verbosity
verbosity =
  Verbosity -> CabalInstallException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO a)
-> (CannotPruneDependencies -> CabalInstallException)
-> CannotPruneDependencies
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> CabalInstallException
SelectComponentTargetError (FilePath -> CabalInstallException)
-> (CannotPruneDependencies -> FilePath)
-> CannotPruneDependencies
-> CabalInstallException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotPruneDependencies -> FilePath
renderCannotPruneDependencies