{-# 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
  ( 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 (..)
  , PackageDB (..)
  , PackageDBStack
  )
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 <- Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
extraFlags
  let
    installLibs = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientInstallFlags -> Flag Bool
cinstInstallLibs ClientInstallFlags
clientInstallFlags)

    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.

  (pkgSpecs, uris, targetSelectors, config) <-
    let
      with = do
        (pkgSpecs, targetSelectors, 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
        return (pkgSpecs, [], targetSelectors, baseConfig)

      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 null targetStrings
        then with
        else withProjectOrGlobalConfig ignoreProject with 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 =
        ProjectConfigBuildOnly
          { projectConfigLogsDir
          }
      , projectConfigShared =
        ProjectConfigShared
          { projectConfigHcFlavor
          , projectConfigHcPath
          , projectConfigHcPkg
          , projectConfigStoreDir
          , projectConfigProgPathExtra
          , projectConfigPackageDBs
          }
      , projectConfigLocalPackages =
        PackageConfig
          { packageConfigProgramPaths
          , packageConfigProgramArgs
          , packageConfigProgramPathExtra
          }
      } = config

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

  configProgDb <- prependProgramSearchPath verbosity ((fromNubList packageConfigProgramPathExtra) ++ (fromNubList projectConfigProgPathExtra)) defaultProgramDb
  let
    -- ProgramDb with directly user specified paths
    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{compilerId = CompilerId compilerFlavor compilerVersion}, platform, progDb) <-
    configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity

  let
    GhcImplInfo{supportsPkgEnvFiles} = getImplInfo compiler

  (usedPackageEnvFlag, envFile) <- getEnvFile clientInstallFlags platform compilerVersion
  (usedExistingPkgEnvFile, existingEnvEntries) <-
    getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
  packageDbs <- getPackageDbStack compiler projectConfigStoreDir projectConfigLogsDir projectConfigPackageDBs
  installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb

  let
    (envSpecs, nonGlobalEnvEntries) =
      getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs

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

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

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

    -- check for targets already in env
    let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
        getPackageName = PackageSpecifier UnresolvedSourcePackage -> PackageName
forall pkg. Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget
        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 = [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 -> 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 -> 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
    (envSpecs', nonGlobalEnvEntries') <-
      if null nameIntersection
        then pure (envSpecs, map snd nonGlobalEnvEntries)
        else
          if forceInstall
            then
              let 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 = ((PackageName, GhcEnvironmentFileEntry) -> GhcEnvironmentFileEntry)
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, GhcEnvironmentFileEntry) -> GhcEnvironmentFileEntry
forall a b. (a, b) -> b
snd ([(PackageName, GhcEnvironmentFileEntry)]
 -> [GhcEnvironmentFileEntry])
-> ([(PackageName, GhcEnvironmentFileEntry)]
    -> [(PackageName, GhcEnvironmentFileEntry)])
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PackageName, GhcEnvironmentFileEntry) -> Bool)
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [(PackageName, GhcEnvironmentFileEntry)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, GhcEnvironmentFileEntry)
e -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (PackageName, GhcEnvironmentFileEntry) -> PackageName
forall a b. (a, b) -> a
fst (PackageName, GhcEnvironmentFileEntry)
e PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) ([(PackageName, GhcEnvironmentFileEntry)]
 -> [GhcEnvironmentFileEntry])
-> [(PackageName, GhcEnvironmentFileEntry)]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$ [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries
               in pure (es, nge)
            else dieWithException verbosity $ PackagesAlreadyExistInEnvfile envFile (map prettyShow $ S.toList nameIntersection)

    -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that
    -- we can solve with regards to packages installed locally but not in the upstream repo
    let installedPacks = InstalledPackageIndex -> [(PackageName, [InstalledPackageInfo])]
forall a. PackageIndex a -> [(PackageName, [a])]
PI.allPackagesByName InstalledPackageIndex
installedIndex
        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' = [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

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

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

    printPlan verbosity baseCtx buildCtx
    let 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 =
        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?
    unless
      (dryRun || installLibs)
      (traverseInstall (installCheckUnitExes InstallCheckOnly) installCfg)

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

    -- Having built everything, do the install.
    unless dryRun $
      if installLibs
        then
          installLibraries
            verbosity
            buildCtx
            installedIndex
            compiler
            packageDbs
            envFile
            nonGlobalEnvEntries'
            (not usedExistingPkgEnvFile && not usedPackageEnvFlag)
        else -- Install any built exe by symlinking or copying it we don't use
        -- BuildOutcomes because we also need the component names
          traverseInstall (installCheckUnitExes InstallCheckInstall) 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 (ConfigFlags -> Flag Verbosity
configVerbosity 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
      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
      traverse_ actionOnExe . Map.toList $ targetsMap 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.
  baseCtx <- Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
reducedVerbosity ProjectConfig
cliConfig CurrentCommand
InstallCommand

  (pkgSpecs, targetSelectors) <-
    -- If every target is already resolved to a package id, we can return without any further parsing.
    if null unresolvedTargetStrings
      then return (parsedPkgSpecs, 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.
        (resolvedPkgSpecs, resolvedTargets) <-
          resolveTargetSelectorsInProjectBaseContext verbosity baseCtx unresolvedTargetStrings targetFilter
        return (resolvedPkgSpecs ++ parsedPkgSpecs, resolvedTargets ++ 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 -> [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
  return (pkgSpecs, targetSelectors, 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

  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)

  targetSelectors <-
    readTargetSelectors (localPackages baseCtx) Nothing targetStrings
      >>= \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

  getSpecsAndTargetSelectors
    verbosity
    reducedVerbosity
    sourcePkgDb
    targetSelectors
    (distDirLayout baseCtx)
    baseCtx
    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
  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
      { projectConfigLogsDir
      } = projectConfigBuildOnly globalConfig

    ProjectConfigShared
      { projectConfigStoreDir
      } = projectConfigShared globalConfig

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

  cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir

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

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

  for_ (concatMap woPackageNames tss) $ \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]
    (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
    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 -> [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)
  return (packageSpecifiers, uris, packageTargets, 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 <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
  pure $ savedClientInstallFlags savedConfig `mappend` 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, hackageNames) <-
      Verbosity
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages
        Verbosity
verbosity
        SourcePackageDb
sourcePkgDb
        ElaboratedInstallPlan
elaboratedPlan
        [TargetSelector]
targetSelectors

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

      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
-> 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
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 = (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 = [PackageName
-> [PackageProperty] -> PackageSpecifier UnresolvedSourcePackage
forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pn [] | PackageName
pn <- [PackageName]
hackageNames]

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

    createDirectoryIfMissing True (distSdistDirectory distDirLayout)

    unless (Map.null targetsMap) $ for_ (localPackages baseCtx) $ \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 null targetsMap
      then return (hackagePkgs, hackageTargets)
      else return (localPkgs ++ hackagePkgs, localTargets ++ 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).
      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'

      return (targets, 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
    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 =
          TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets TargetAction
TargetActionBuild TargetsMap
targets ElaboratedInstallPlan
elaboratedPlan
    prunedElaboratedPlan <-
      if buildSettingOnlyDeps (buildSettings baseCtx)
        then
          either (reportCannotPruneDependencies verbosity) return $
            pruneInstallPlanToDependencies
              (Map.keysSet targets)
              prunedToTargetsElaboratedPlan
        else return prunedToTargetsElaboratedPlan

    return (prunedElaboratedPlan, 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
    installPath <- IO FilePath
defaultInstallPath
    let storeDirLayout = CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout (CabalDirLayout -> StoreDirLayout)
-> CabalDirLayout -> StoreDirLayout
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx

        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 -> 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 =
          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
exe = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
exe FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension Platform
platform

        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
"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

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

    -- This is in IO as we will make environment checks, to decide which install
    -- method is best.
    let 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
              symlinks <- Verbosity -> IO Bool
trySymlink Verbosity
verbosity
              return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
          | Bool
otherwise = InstallMethod -> IO InstallMethod
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return InstallMethod
InstallMethodSymlink

    installMethod <- flagElim defaultMethod return $ cinstInstallMethod installClientFlags

    return $ InstallExe installMethod installdir mkUnitBinDir mkExeName mkFinalExeName

-- | Install any built library by adding it to the default ghc environment
installLibraries
  :: Verbosity
  -> ProjectBuildContext
  -> PI.PackageIndex InstalledPackageInfo
  -> Compiler
  -> PackageDBStack
  -> FilePath
  -- ^ Environment file
  -> [GhcEnvironmentFileEntry]
  -> 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
-> PackageDBStack
-> FilePath
-> [GhcEnvironmentFileEntry]
-> Bool
-> IO ()
installLibraries
  Verbosity
verbosity
  ProjectBuildContext
buildCtx
  InstalledPackageIndex
installedIndex
  Compiler
compiler
  PackageDBStack
packageDbs'
  FilePath
envFile
  [GhcEnvironmentFileEntry]
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 :: PackageDB -> IO Bool
validDb (SpecificPackageDB FilePath
fp) = FilePath -> IO Bool
doesPathExist FilePath
fp
            validDb PackageDB
_ = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        -- if a user "installs" a global package and no existing cabal db exists, none will be created.
        -- this ensures we don't add the "phantom" path to the file.
        packageDbs <- (PackageDB -> IO Bool) -> PackageDBStack -> IO PackageDBStack
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM PackageDB -> IO Bool
validDb PackageDBStack
packageDbs'
        let
          getLatest =
            ((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]] -> [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 = UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId (UnitId -> GhcEnvironmentFileEntry)
-> (InstalledPackageInfo -> UnitId)
-> InstalledPackageInfo
-> GhcEnvironmentFileEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
installedUnitId (InstalledPackageInfo -> GhcEnvironmentFileEntry)
-> [InstalledPackageInfo] -> [GhcEnvironmentFileEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstalledPackageInfo]
globalLatest
          baseEntries =
            GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack GhcEnvironmentFileEntry
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. a -> [a] -> [a]
: (PackageDB -> GhcEnvironmentFileEntry)
-> PackageDBStack -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb PackageDBStack
packageDbs
          pkgEntries =
            [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. Ord a => [a] -> [a]
ordNub ([GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry])
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$
              [GhcEnvironmentFileEntry]
globalEntries
                [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
envEntries
                [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents (ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx)
          contents' = [GhcEnvironmentFileEntry] -> FilePath
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry]
baseEntries [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
pkgEntries)
        createDirectoryIfMissing True (takeDirectory envFile)
        writeFileAtomic envFile (BS.pack contents')
        when showWarning $
          warn verbosity $
            "The libraries were installed by creating a global GHC environment file at:\n"
              ++ envFile
              ++ "\n"
              ++ "\n"
              ++ "The presence of such an environment file is likely to confuse or break other "
              ++ "tools because it changes GHC's behaviour: it changes the default package set in "
              ++ "ghc and ghci from its normal value (which is \"all boot libraries\"). GHC "
              ++ "environment files are little-used and often not tested for.\n"
              ++ "\n"
              ++ "Furthermore, management of these environment files is still more difficult than "
              ++ "it could be; see e.g. https://github.com/haskell/cabal/issues/6481 .\n"
              ++ "\n"
              ++ "Double-check that creating a global GHC environment file is really what you "
              ++ "wanted! You can limit the effects of the environment file by creating it in a "
              ++ "specific directory using the --package-env flag. For example, use:\n"
              ++ "\n"
              ++ "cabal install --lib <packages...> --package-env .\n"
              ++ "\n"
              ++ "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]
  -> Bool
  -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries :: forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> Bool
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry]
entries Bool
installLibs =
  if Bool
installLibs
    then ([PackageSpecifier a]
forall {a}. [PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
envEntries')
    else ([], [(PackageName, GhcEnvironmentFileEntry)]
envEntries')
  where
    ([PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
envEntries') = InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry]
entries

environmentFileToSpecifiers
  :: PI.InstalledPackageIndex
  -> [GhcEnvironmentFileEntry]
  -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers :: forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers InstalledPackageIndex
ipi = (GhcEnvironmentFileEntry
 -> ([PackageSpecifier a],
     [(PackageName, GhcEnvironmentFileEntry)]))
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((GhcEnvironmentFileEntry
  -> ([PackageSpecifier a],
      [(PackageName, GhcEnvironmentFileEntry)]))
 -> [GhcEnvironmentFileEntry]
 -> ([PackageSpecifier a],
     [(PackageName, GhcEnvironmentFileEntry)]))
-> (GhcEnvironmentFileEntry
    -> ([PackageSpecifier a],
        [(PackageName, GhcEnvironmentFileEntry)]))
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
forall a b. (a -> b) -> a -> b
$ \case
  (GhcEnvFilePackageId UnitId
unitId)
    | Just
        InstalledPackageInfo
          { sourcePackageId :: InstalledPackageInfo -> 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
GhcEnvFilePackageId UnitId
installedUnitId)])
  GhcEnvironmentFileEntry
_ -> ([], [])

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

-- | 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
mkExeName UnqualComponentName
exe)
      (UnqualComponentName -> FilePath
mkFinalExeName 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
    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 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 ()
forall {a}. Pretty a => (Bool, a) -> 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 ()
forall {a}. Pretty a => (Bool, a) -> 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, a) -> IO ()
warnAbout (Bool
True, a
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      warnAbout (Bool
False, a
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 -> a -> FilePath
forall {a}. Pretty a => FilePath -> a -> FilePath
errorMessage FilePath
installDir a
exe)

      installAndWarn :: UnqualComponentName -> IO ()
installAndWarn UnqualComponentName
exe = do
        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
        unless success $ dieWithException verbosity $ InstallUnitExes (errorMessage installDir exe)

      errorMessage :: FilePath -> a -> FilePath
errorMessage FilePath
installdir a
exe = case OverwritePolicy
overwritePolicy of
        OverwritePolicy
NeverOverwrite ->
          FilePath
"Path '"
            FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> (FilePath
installdir FilePath -> FilePath -> FilePath
</> a -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow a
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
<> a -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow a
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
"'"
    exists <- FilePath -> IO Bool
doesPathExist FilePath
destination
    case (exists, 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
        isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
destination
        if isDir
          then removeDirectory destination
          else removeFile destination
      copy :: IO Bool
copy = FilePath -> FilePath -> IO ()
copyFile FilePath
source FilePath
destination IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
      overwrite :: IO Bool
      overwrite :: IO Bool
overwrite = IO ()
remove IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Bool
copy
      maybeOverwrite :: IO Bool
      maybeOverwrite :: IO Bool
maybeOverwrite =
        FilePath -> IO Bool -> IO Bool
promptRun
          FilePath
"Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
          IO Bool
overwrite

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

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

-- | Gets the file path to the request environment file. 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
  appDir <- IO FilePath
getGhcAppDir
  case flagToMaybe (cinstEnvironmentPath 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
          spec' <- FilePath -> IO FilePath
makeAbsolute FilePath
spec
          isDir <- doesDirectoryExist spec'
          if isDir
            then -- If spec is a directory, then make an ambient environment inside
            -- that directory.
              return (True, getLocalEnv spec' platform compilerVersion)
            else -- Otherwise, treat it like a literal file path.
              return (True, 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])
getExistingEnvEntries :: Verbosity
-> CompilerFlavor
-> Bool
-> FilePath
-> IO (Bool, [GhcEnvironmentFileEntry])
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile = do
  envFileExists <- FilePath -> IO Bool
doesFileExist FilePath
envFile
  (usedExisting, allEntries) <-
    if (compilerFlavor == GHC || compilerFlavor == GHCJS)
      && supportsPkgEnvFiles
      && envFileExists
      then catch ((True,) <$> readGhcEnvironmentFile envFile) $ \(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])
-> IO (Bool, [GhcEnvironmentFileEntry])
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Bool, [GhcEnvironmentFileEntry])
-> IO (Bool, [GhcEnvironmentFileEntry])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, [])
      else return (False, [])
  return (usedExisting, filterEnvEntries allEntries)
  where
    -- Why? We know what the first part will be, we only care about the packages.
    filterEnvEntries :: [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
filterEnvEntries = (GhcEnvironmentFileEntry -> Bool)
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter ((GhcEnvironmentFileEntry -> Bool)
 -> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry])
-> (GhcEnvironmentFileEntry -> Bool)
-> [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$ \case
      GhcEnvFilePackageId UnitId
_ -> Bool
True
      GhcEnvironmentFileEntry
_ -> Bool
False

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

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

getPackageDbStack
  :: Compiler
  -> Flag FilePath
  -> Flag FilePath
  -> [Maybe PackageDB]
  -> IO PackageDBStack
getPackageDbStack :: Compiler
-> Flag FilePath
-> Flag FilePath
-> [Maybe PackageDB]
-> IO PackageDBStack
getPackageDbStack Compiler
compiler Flag FilePath
storeDirFlag Flag FilePath
logsDirFlag [Maybe PackageDB]
packageDbs = do
  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 = Flag FilePath -> Maybe FilePath
forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
logsDirFlag
  cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
  pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compiler 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