cabal-install/src/Distribution/Client/CmdInstall.hs

   1 {-# LANGUAGE LambdaCase #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE RecordWildCards #-}
   4 {-# LANGUAGE ScopedTypeVariables #-}
   5
   6 -- | cabal-install CLI command: build
   7 module Distribution.Client.CmdInstall
   8   ( -- * The @build@ CLI and action
   9     installCommand
  10   , installAction
  11
  12     -- * Internals exposed for testing
  13   , selectPackageTargets
  14   , selectComponentTarget
  15
  16     -- * Internals exposed for CmdRepl + CmdRun
  17   , establishDummyDistDirLayout
  18   , establishDummyProjectBaseContext
  19   ) where
  20
  21 import Distribution.Client.Compat.Prelude
  22 import Distribution.Compat.Directory
  23   ( doesPathExist
  24   )
  25 import Prelude ()
  26
  27 import Distribution.Client.CmdErrorMessages
  28 import Distribution.Client.CmdSdist
  29 import Distribution.Client.ProjectOrchestration
  30 import Distribution.Client.TargetProblem
  31   ( TargetProblem (..)
  32   , TargetProblem'
  33   )
  34
  35 import Distribution.Client.CmdInstall.ClientInstallFlags
  36 import Distribution.Client.CmdInstall.ClientInstallTargetSelector
  37
  38 import Distribution.Client.Config
  39   ( SavedConfig (..)
  40   , defaultInstallPath
  41   , loadConfig
  42   )
  43 import Distribution.Client.DistDirLayout
  44   ( CabalDirLayout (..)
  45   , DistDirLayout (..)
  46   , StoreDirLayout (..)
  47   , cabalStoreDirLayout
  48   , mkCabalDirLayout
  49   )
  50 import Distribution.Client.IndexUtils
  51   ( getInstalledPackages
  52   , getSourcePackages
  53   )
  54 import qualified Distribution.Client.InstallPlan as InstallPlan
  55 import Distribution.Client.InstallSymlink
  56   ( Symlink (..)
  57   , promptRun
  58   , symlinkBinary
  59   , symlinkableBinary
  60   , trySymlink
  61   )
  62 import Distribution.Client.NixStyleOptions
  63   ( NixStyleFlags (..)
  64   , defaultNixStyleFlags
  65   , nixStyleOptions
  66   )
  67 import Distribution.Client.ProjectConfig
  68   ( ProjectPackageLocation (..)
  69   , fetchAndReadSourcePackages
  70   , projectConfigWithBuilderRepoContext
  71   , resolveBuildTimeSettings
  72   , withProjectOrGlobalConfig
  73   )
  74 import Distribution.Client.ProjectConfig.Types
  75   ( MapMappend (..)
  76   , PackageConfig (..)
  77   , ProjectConfig (..)
  78   , ProjectConfigBuildOnly (..)
  79   , ProjectConfigShared (..)
  80   , getMapLast
  81   , getMapMappend
  82   , projectConfigBuildOnly
  83   , projectConfigConfigFile
  84   , projectConfigLogsDir
  85   , projectConfigStoreDir
  86   )
  87 import Distribution.Client.ProjectFlags (ProjectFlags (..))
  88 import Distribution.Client.ProjectPlanning
  89   ( storePackageInstallDirs'
  90   )
  91 import Distribution.Client.ProjectPlanning.Types
  92   ( ElaboratedInstallPlan
  93   )
  94 import Distribution.Client.RebuildMonad
  95   ( runRebuild
  96   )
  97 import Distribution.Client.Setup
  98   ( ConfigFlags (..)
  99   , GlobalFlags (..)
 100   , InstallFlags (..)
 101   )
 102 import Distribution.Client.Types
 103   ( PackageLocation (..)
 104   , PackageSpecifier (..)
 105   , SourcePackageDb (..)
 106   , UnresolvedSourcePackage
 107   )
 108 import Distribution.Client.Types.OverwritePolicy
 109   ( OverwritePolicy (..)
 110   )
 111 import Distribution.Package
 112   ( Package (..)
 113   , PackageName
 114   , mkPackageName
 115   , unPackageName
 116   )
 117 import Distribution.Simple.BuildPaths
 118   ( exeExtension
 119   )
 120 import Distribution.Simple.Command
 121   ( CommandUI (..)
 122   , optionName
 123   , usageAlternatives
 124   )
 125 import Distribution.Simple.Compiler
 126   ( Compiler (..)
 127   , CompilerFlavor (..)
 128   , CompilerId (..)
 129   , PackageDB (..)
 130   , PackageDBStack
 131   )
 132 import Distribution.Simple.Configure
 133   ( configCompilerEx
 134   )
 135 import Distribution.Simple.Flag
 136   ( flagElim
 137   , flagToMaybe
 138   , fromFlagOrDefault
 139   )
 140 import Distribution.Simple.GHC
 141   ( GhcEnvironmentFileEntry (..)
 142   , GhcImplInfo (..)
 143   , ParseErrorExc
 144   , getGhcAppDir
 145   , getImplInfo
 146   , ghcPlatformAndVersionString
 147   , readGhcEnvironmentFile
 148   , renderGhcEnvironmentFile
 149   )
 150 import qualified Distribution.Simple.InstallDirs as InstallDirs
 151 import qualified Distribution.Simple.PackageIndex as PI
 152 import Distribution.Simple.Program.Db
 153   ( defaultProgramDb
 154   , modifyProgramSearchPath
 155   , userSpecifyArgss
 156   , userSpecifyPaths
 157   )
 158 import Distribution.Simple.Program.Find
 159   ( ProgramSearchPathEntry (..)
 160   )
 161 import Distribution.Simple.Setup
 162   ( Flag (..)
 163   , installDirsOptions
 164   )
 165 import Distribution.Simple.Utils
 166   ( createDirectoryIfMissingVerbose
 167   , dieWithException
 168   , notice
 169   , ordNub
 170   , safeHead
 171   , warn
 172   , withTempDirectory
 173   , wrapText
 174   )
 175 import Distribution.Solver.Types.PackageConstraint
 176   ( PackageProperty (..)
 177   )
 178 import Distribution.Solver.Types.PackageIndex
 179   ( lookupPackageName
 180   , searchByName
 181   )
 182 import Distribution.Solver.Types.SourcePackage
 183   ( SourcePackage (..)
 184   )
 185 import Distribution.System
 186   ( OS (Windows)
 187   , Platform
 188   , buildOS
 189   )
 190 import Distribution.Types.InstalledPackageInfo
 191   ( InstalledPackageInfo (..)
 192   )
 193 import Distribution.Types.PackageId
 194   ( PackageIdentifier (..)
 195   )
 196 import Distribution.Types.UnitId
 197   ( UnitId
 198   )
 199 import Distribution.Types.UnqualComponentName
 200   ( UnqualComponentName
 201   , unUnqualComponentName
 202   )
 203 import Distribution.Types.Version
 204   ( Version
 205   , nullVersion
 206   )
 207 import Distribution.Types.VersionRange
 208   ( thisVersion
 209   )
 210 import Distribution.Utils.Generic
 211   ( writeFileAtomic
 212   )
 213 import Distribution.Verbosity
 214   ( lessVerbose
 215   , normal
 216   )
 217
 218 import qualified Data.ByteString.Lazy.Char8 as BS
 219 import qualified Data.List.NonEmpty as NE
 220 import qualified Data.Map as Map
 221 import Data.Ord
 222   ( Down (..)
 223   )
 224 import qualified Data.Set as S
 225 import Distribution.Client.Errors
 226 import Distribution.Utils.NubList
 227   ( fromNubList
 228   )
 229 import Network.URI (URI)
 230 import System.Directory
 231   ( copyFile
 232   , createDirectoryIfMissing
 233   , doesDirectoryExist
 234   , doesFileExist
 235   , getTemporaryDirectory
 236   , makeAbsolute
 237   , removeDirectory
 238   , removeFile
 239   )
 240 import System.FilePath
 241   ( takeBaseName
 242   , takeDirectory
 243   , (<.>)
 244   , (</>)
 245   )
 246
 247 -- | Check or check then install an exe. The check is to see if the overwrite
 248 -- policy allows installation.
 249 data InstallCheck
 250   = -- | Only check if install is permitted.
 251     InstallCheckOnly
 252   | -- | Actually install but check first if permitted.
 253     InstallCheckInstall
 254
 255 type InstallAction =
 256   Verbosity
 257   -> OverwritePolicy
 258   -> InstallExe
 259   -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
 260   -> IO ()
 261
 262 data InstallCfg = InstallCfg
 263   { verbosity :: Verbosity
 264   , baseCtx :: ProjectBaseContext
 265   , buildCtx :: ProjectBuildContext
 266   , platform :: Platform
 267   , compiler :: Compiler
 268   , installConfigFlags :: ConfigFlags
 269   , installClientFlags :: ClientInstallFlags
 270   }
 271
 272 -- | A record of install method, install directory and file path functions
 273 -- needed by actions that either check if an install is possible or actually
 274 -- perform an installation. This is for installation of executables only.
 275 data InstallExe = InstallExe
 276   { installMethod :: InstallMethod
 277   , installDir :: FilePath
 278   , mkSourceBinDir :: UnitId -> FilePath
 279   -- ^ A function to get an UnitId's store directory.
 280   , mkExeName :: UnqualComponentName -> FilePath
 281   -- ^ A function to get an exe's filename.
 282   , mkFinalExeName :: UnqualComponentName -> FilePath
 283   -- ^ A function to get an exe's final possibly different to the name in the
 284   -- store.
 285   }
 286
 287 installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
 288 installCommand =
 289   CommandUI
 290     { commandName = "v2-install"
 291     , commandSynopsis = "Install packages."
 292     , commandUsage =
 293         usageAlternatives
 294           "v2-install"
 295           ["[TARGETS] [FLAGS]"]
 296     , commandDescription = Just $ \_ ->
 297         wrapText $
 298           "Installs one or more packages. This is done by installing them "
 299             ++ "in the store and symlinking or copying the executables in the directory "
 300             ++ "specified by the --installdir flag (`~/.local/bin/` by default). "
 301             ++ "If you want the installed executables to be available globally, "
 302             ++ "make sure that the PATH environment variable contains that directory. "
 303             ++ "\n\n"
 304             ++ "If TARGET is a library and --lib (provisional) is used, "
 305             ++ "it will be added to the global environment. "
 306             ++ "When doing this, cabal will try to build a plan that includes all "
 307             ++ "the previously installed libraries. This is currently not implemented."
 308     , commandNotes = Just $ \pname ->
 309         "Examples:\n"
 310           ++ "  "
 311           ++ pname
 312           ++ " v2-install\n"
 313           ++ "    Install the package in the current directory\n"
 314           ++ "  "
 315           ++ pname
 316           ++ " v2-install pkgname\n"
 317           ++ "    Install the package named pkgname"
 318           ++ " (fetching it from hackage if necessary)\n"
 319           ++ "  "
 320           ++ pname
 321           ++ " v2-install ./pkgfoo\n"
 322           ++ "    Install the package in the ./pkgfoo directory\n"
 323     , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x
 324     , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags
 325     }
 326   where
 327     -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.
 328     notInstallDirOpt x = not $ optionName x `elem` installDirOptNames
 329     installDirOptNames = map optionName installDirsOptions
 330
 331 -- | The @install@ command actually serves four different needs. It installs:
 332 -- * exes:
 333 --   For example a program from hackage. The behavior is similar to the old
 334 --   install command, except that now conflicts between separate runs of the
 335 --   command are impossible thanks to the store.
 336 --   Exes are installed in the store like a normal dependency, then they are
 337 --   symlinked/copied in the directory specified by --installdir.
 338 --   To do this we need a dummy projectBaseContext containing the targets as
 339 --   extra packages and using a temporary dist directory.
 340 -- * libraries
 341 --   Libraries install through a similar process, but using GHC environment
 342 --   files instead of symlinks. This means that 'v2-install'ing libraries
 343 --   only works on GHC >= 8.0.
 344 --
 345 -- For more details on how this works, see the module
 346 -- "Distribution.Client.ProjectOrchestration"
 347 installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
 348 installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetStrings globalFlags = do
 349   -- Ensure there were no invalid configuration options specified.
 350   verifyPreconditionsOrDie verbosity configFlags'
 351
 352   -- We cannot use establishDummyProjectBaseContext to get these flags, since
 353   -- it requires one of them as an argument. Normal establishProjectBaseContext
 354   -- does not, and this is why this is done only for the install command
 355   clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'
 356
 357   let
 358     installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
 359     targetFilter = if installLibs then Just LibKind else Just ExeKind
 360     targetStrings' = if null targetStrings then ["."] else targetStrings
 361
 362     -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris.
 363     -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where
 364     -- no project file is present (including an implicit one derived from being in a package directory)
 365     -- or where the --ignore-project flag is passed explicitly. In such a case we only parse colon-free target selectors
 366     -- as selectors, and otherwise parse things as URIs.
 367
 368     -- However, in the special case where --ignore-project is passed with no selectors, we want to act as though this is
 369     -- a "normal" ignore project that actually builds and installs the selected package.
 370
 371     withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
 372     withProject = do
 373       let reducedVerbosity = lessVerbose verbosity
 374
 375       -- First, we need to learn about what's available to be installed.
 376       localBaseCtx <-
 377         establishProjectBaseContext reducedVerbosity cliConfig InstallCommand
 378       let localDistDirLayout = distDirLayout localBaseCtx
 379       pkgDb <-
 380         projectConfigWithBuilderRepoContext
 381           reducedVerbosity
 382           (buildSettings localBaseCtx)
 383           (getSourcePackages verbosity)
 384
 385       let
 386         (targetStrings'', packageIds) =
 387           partitionEithers
 388             . flip fmap targetStrings'
 389             $ \str -> case simpleParsec str of
 390               Just (pkgId :: PackageId)
 391                 | pkgVersion pkgId /= nullVersion -> Right pkgId
 392               _ -> Left str
 393         packageSpecifiers =
 394           flip fmap packageIds $ \case
 395             PackageIdentifier{..}
 396               | pkgVersion == nullVersion -> NamedPackage pkgName []
 397               | otherwise ->
 398                   NamedPackage
 399                     pkgName
 400                     [ PackagePropertyVersion
 401                         (thisVersion pkgVersion)
 402                     ]
 403         packageTargets =
 404           flip TargetPackageNamed targetFilter . pkgName <$> packageIds
 405
 406       if null targetStrings'' -- if every selector is already resolved as a packageid, return without further parsing.
 407         then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)
 408         else do
 409           targetSelectors <-
 410             either (reportTargetSelectorProblems verbosity) return
 411               =<< readTargetSelectors
 412                 (localPackages localBaseCtx)
 413                 Nothing
 414                 targetStrings''
 415
 416           (specs, selectors) <-
 417             getSpecsAndTargetSelectors
 418               verbosity
 419               reducedVerbosity
 420               pkgDb
 421               targetSelectors
 422               localDistDirLayout
 423               localBaseCtx
 424               targetFilter
 425
 426           return
 427             ( specs ++ packageSpecifiers
 428             , []
 429             , selectors ++ packageTargets
 430             , projectConfig localBaseCtx
 431             )
 432
 433     withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
 434     withoutProject _ | null targetStrings = withProject -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir
 435     withoutProject globalConfig = do
 436       tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'
 437       let
 438         projectConfig = globalConfig <> cliConfig
 439
 440         ProjectConfigBuildOnly
 441           { projectConfigLogsDir
 442           } = projectConfigBuildOnly projectConfig
 443
 444         ProjectConfigShared
 445           { projectConfigStoreDir
 446           } = projectConfigShared projectConfig
 447
 448         mlogsDir = flagToMaybe projectConfigLogsDir
 449         mstoreDir = flagToMaybe projectConfigStoreDir
 450       cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
 451
 452       let
 453         buildSettings =
 454           resolveBuildTimeSettings
 455             verbosity
 456             cabalDirLayout
 457             projectConfig
 458
 459       SourcePackageDb{packageIndex} <-
 460         projectConfigWithBuilderRepoContext
 461           verbosity
 462           buildSettings
 463           (getSourcePackages verbosity)
 464
 465       for_ (concatMap woPackageNames tss) $ \name -> do
 466         when (null (lookupPackageName packageIndex name)) $ do
 467           let xs = searchByName packageIndex (unPackageName name)
 468           let emptyIf True _ = []
 469               emptyIf False zs = zs
 470               str2 =
 471                 emptyIf
 472                   (null xs)
 473                   [ "Did you mean any of the following?\n"
 474                   , unlines (("- " ++) . unPackageName . fst <$> xs)
 475                   ]
 476           dieWithException verbosity $ WithoutProject (unPackageName name) str2
 477
 478       let
 479         (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
 480         packageTargets = map woPackageTargets tss
 481
 482       return (packageSpecifiers, uris, packageTargets, projectConfig)
 483
 484   (specs, uris, targetSelectors, config) <-
 485     withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject
 486
 487   let
 488     ProjectConfig
 489       { projectConfigBuildOnly =
 490         ProjectConfigBuildOnly
 491           { projectConfigLogsDir
 492           }
 493       , projectConfigShared =
 494         ProjectConfigShared
 495           { projectConfigHcFlavor
 496           , projectConfigHcPath
 497           , projectConfigHcPkg
 498           , projectConfigStoreDir
 499           }
 500       , projectConfigLocalPackages =
 501         PackageConfig
 502           { packageConfigProgramPaths
 503           , packageConfigProgramArgs
 504           , packageConfigProgramPathExtra
 505           }
 506       } = config
 507
 508     hcFlavor = flagToMaybe projectConfigHcFlavor
 509     hcPath = flagToMaybe projectConfigHcPath
 510     hcPkg = flagToMaybe projectConfigHcPkg
 511
 512     -- ProgramDb with directly user specified paths
 513     preProgDb =
 514       userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
 515         . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
 516         . modifyProgramSearchPath
 517           ( ++
 518               [ ProgramSearchPathDir dir
 519               | dir <- fromNubList packageConfigProgramPathExtra
 520               ]
 521           )
 522         $ defaultProgramDb
 523
 524   -- progDb is a program database with compiler tools configured properly
 525   ( compiler@Compiler
 526       { compilerId =
 527         compilerId@(CompilerId compilerFlavor compilerVersion)
 528       }
 529     , platform
 530     , progDb
 531     ) <-
 532     configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity
 533
 534   let
 535     GhcImplInfo{supportsPkgEnvFiles} = getImplInfo compiler
 536
 537   envFile <- getEnvFile clientInstallFlags platform compilerVersion
 538   existingEnvEntries <-
 539     getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile
 540   packageDbs <- getPackageDbStack compilerId projectConfigStoreDir projectConfigLogsDir
 541   installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb
 542
 543   let
 544     (envSpecs, nonGlobalEnvEntries) =
 545       getEnvSpecsAndNonGlobalEntries installedIndex existingEnvEntries installLibs
 546
 547   -- Second, we need to use a fake project to let Cabal build the
 548   -- installables correctly. For that, we need a place to put a
 549   -- temporary dist directory.
 550   globalTmp <- getTemporaryDirectory
 551
 552   withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do
 553     distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir
 554
 555     uriSpecs <-
 556       runRebuild tmpDir $
 557         fetchAndReadSourcePackages
 558           verbosity
 559           distDirLayout
 560           (projectConfigShared config)
 561           (projectConfigBuildOnly config)
 562           [ProjectPackageRemoteTarball uri | uri <- uris]
 563
 564     -- check for targets already in env
 565     let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
 566         getPackageName (NamedPackage pn _) = pn
 567         getPackageName (SpecificSourcePackage (SourcePackage pkgId _ _ _)) = pkgName pkgId
 568         targetNames = S.fromList $ map getPackageName (specs ++ uriSpecs)
 569         envNames = S.fromList $ map getPackageName envSpecs
 570         forceInstall = fromFlagOrDefault False $ installOverrideReinstall installFlags
 571         nameIntersection = S.intersection targetNames envNames
 572
 573     -- we check for intersections in targets with the existing env
 574     (envSpecs', nonGlobalEnvEntries') <-
 575       if null nameIntersection
 576         then pure (envSpecs, map snd nonGlobalEnvEntries)
 577         else
 578           if forceInstall
 579             then
 580               let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs
 581                   nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries
 582                in pure (es, nge)
 583             else dieWithException verbosity $ PackagesAlreadyExistInEnvfile envFile (map prettyShow $ S.toList nameIntersection)
 584
 585     -- 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
 586     let installedPacks = PI.allPackagesByName installedIndex
 587         newEnvNames = S.fromList $ map getPackageName envSpecs'
 588         installedIndex' = PI.fromList . concatMap snd . filter (\p -> fst p `S.member` newEnvNames) $ installedPacks
 589
 590     baseCtx <-
 591       establishDummyProjectBaseContext
 592         verbosity
 593         config
 594         distDirLayout
 595         (envSpecs' ++ specs ++ uriSpecs)
 596         InstallCommand
 597
 598     buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors
 599
 600     printPlan verbosity baseCtx buildCtx
 601     let installCfg = InstallCfg verbosity baseCtx buildCtx platform compiler configFlags clientInstallFlags
 602
 603     let
 604       dryRun =
 605         buildSettingDryRun (buildSettings baseCtx)
 606           || buildSettingOnlyDownload (buildSettings baseCtx)
 607
 608     -- Before building, check if we could install any built exe by symlinking or
 609     -- copying it?
 610     unless
 611       (dryRun || installLibs)
 612       (traverseInstall (installCheckUnitExes InstallCheckOnly) installCfg)
 613
 614     buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
 615     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
 616
 617     -- Having built everything, do the install.
 618     unless dryRun $
 619       if installLibs
 620         then
 621           installLibraries
 622             verbosity
 623             buildCtx
 624             installedIndex
 625             compiler
 626             packageDbs
 627             envFile
 628             nonGlobalEnvEntries'
 629         else -- Install any built exe by symlinking or copying it we don't use
 630         -- BuildOutcomes because we also need the component names
 631           traverseInstall (installCheckUnitExes InstallCheckInstall) installCfg
 632   where
 633     configFlags' = disableTestsBenchsByDefault configFlags
 634     verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
 635     ignoreProject = flagIgnoreProject projectFlags
 636     baseCliConfig =
 637       commandLineFlagsToProjectConfig
 638         globalFlags
 639         flags{configFlags = configFlags'}
 640         clientInstallFlags'
 641     cliConfig = addLocalConfigToTargets baseCliConfig targetStrings
 642     globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 643
 644     -- Do the install action for each executable in the install configuration.
 645     traverseInstall :: InstallAction -> InstallCfg -> IO ()
 646     traverseInstall action cfg@InstallCfg{verbosity = v, buildCtx, installClientFlags} = do
 647       let overwritePolicy = fromFlagOrDefault NeverOverwrite $ cinstOverwritePolicy installClientFlags
 648       actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg
 649       traverse_ actionOnExe . Map.toList $ targetsMap buildCtx
 650
 651 -- | Treat all direct targets of install command as local packages: #8637
 652 addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig
 653 addLocalConfigToTargets config targetStrings =
 654   config
 655     { projectConfigSpecificPackage =
 656         projectConfigSpecificPackage config
 657           <> MapMappend (Map.fromList targetPackageConfigs)
 658     }
 659   where
 660     localConfig = projectConfigLocalPackages config
 661     targetPackageConfigs = map (\x -> (mkPackageName x, localConfig)) targetStrings
 662
 663 -- | Verify that invalid config options were not passed to the install command.
 664 --
 665 -- If an invalid configuration is found the command will @dieWithException@.
 666 verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
 667 verifyPreconditionsOrDie verbosity configFlags = do
 668   -- We never try to build tests/benchmarks for remote packages.
 669   -- So we set them as disabled by default and error if they are explicitly
 670   -- enabled.
 671   when (configTests configFlags == Flag True) $
 672     dieWithException verbosity ConfigTests
 673   when (configBenchmarks configFlags == Flag True) $
 674     dieWithException verbosity ConfigBenchmarks
 675
 676 getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
 677 getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do
 678   let configFileFlag = globalConfigFile globalFlags
 679   savedConfig <- loadConfig verbosity configFileFlag
 680   pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags
 681
 682 getSpecsAndTargetSelectors
 683   :: Verbosity
 684   -> Verbosity
 685   -> SourcePackageDb
 686   -> [TargetSelector]
 687   -> DistDirLayout
 688   -> ProjectBaseContext
 689   -> Maybe ComponentKindFilter
 690   -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
 691 getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =
 692   withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do
 693     -- Split into known targets and hackage packages.
 694     (targets, hackageNames) <-
 695       partitionToKnownTargetsAndHackagePackages
 696         verbosity
 697         pkgDb
 698         elaboratedPlan
 699         targetSelectors
 700
 701     let
 702       planMap = InstallPlan.toMap elaboratedPlan
 703       targetIds = Map.keys targets
 704
 705       sdistize (SpecificSourcePackage spkg) =
 706         SpecificSourcePackage spkg'
 707         where
 708           sdistPath = distSdistFile localDistDirLayout (packageId spkg)
 709           spkg' = spkg{srcpkgSource = LocalTarballPackage sdistPath}
 710       sdistize named = named
 711
 712       local = sdistize <$> localPackages localBaseCtx
 713
 714       gatherTargets :: UnitId -> TargetSelector
 715       gatherTargets targetId = TargetPackageNamed pkgName targetFilter
 716         where
 717           targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
 718           PackageIdentifier{..} = packageId targetUnit
 719
 720       targets' = fmap gatherTargets targetIds
 721
 722       hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
 723       hackagePkgs = flip NamedPackage [] <$> hackageNames
 724
 725       hackageTargets :: [TargetSelector]
 726       hackageTargets =
 727         flip TargetPackageNamed targetFilter <$> hackageNames
 728
 729     createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)
 730
 731     unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
 732       SpecificSourcePackage pkg ->
 733         packageToSdist
 734           verbosity
 735           (distProjectRootDirectory localDistDirLayout)
 736           TarGzArchive
 737           (distSdistFile localDistDirLayout (packageId pkg))
 738           pkg
 739       NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName
 740
 741     if null targets
 742       then return (hackagePkgs, hackageTargets)
 743       else return (local ++ hackagePkgs, targets' ++ hackageTargets)
 744
 745 -- | Partitions the target selectors into known local targets and hackage packages.
 746 partitionToKnownTargetsAndHackagePackages
 747   :: Verbosity
 748   -> SourcePackageDb
 749   -> ElaboratedInstallPlan
 750   -> [TargetSelector]
 751   -> IO (TargetsMap, [PackageName])
 752 partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
 753   let mTargets =
 754         resolveTargets
 755           selectPackageTargets
 756           selectComponentTarget
 757           elaboratedPlan
 758           (Just pkgDb)
 759           targetSelectors
 760   case mTargets of
 761     Right targets ->
 762       -- Everything is a local dependency.
 763       return (targets, [])
 764     Left errs -> do
 765       -- Not everything is local.
 766       let
 767         (errs', hackageNames) = partitionEithers . flip fmap errs $ \case
 768           TargetAvailableInIndex name -> Right name
 769           err -> Left err
 770
 771       -- report incorrect case for known package.
 772       for_ errs' $ \case
 773         TargetNotInProject hn ->
 774           case searchByName (packageIndex pkgDb) (unPackageName hn) of
 775             [] -> return ()
 776             xs ->
 777               dieWithException verbosity $ UnknownPackage (unPackageName hn) (("- " ++) . unPackageName . fst <$> xs)
 778         _ -> return ()
 779
 780       when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'
 781
 782       let
 783         targetSelectors' = flip filter targetSelectors $ \case
 784           TargetComponentUnknown name _ _
 785             | name `elem` hackageNames -> False
 786           TargetPackageNamed name _
 787             | name `elem` hackageNames -> False
 788           _ -> True
 789
 790       -- This can't fail, because all of the errors are
 791       -- removed (or we've given up).
 792       targets <-
 793         either (reportBuildTargetProblems verbosity) return $
 794           resolveTargets
 795             selectPackageTargets
 796             selectComponentTarget
 797             elaboratedPlan
 798             Nothing
 799             targetSelectors'
 800
 801       return (targets, hackageNames)
 802
 803 constructProjectBuildContext
 804   :: Verbosity
 805   -> ProjectBaseContext
 806   -- ^ The synthetic base context to use to produce the full build context.
 807   -> [TargetSelector]
 808   -> IO ProjectBuildContext
 809 constructProjectBuildContext verbosity baseCtx targetSelectors = do
 810   runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
 811     -- Interpret the targets on the command line as build targets
 812     targets <-
 813       either (reportBuildTargetProblems verbosity) return $
 814         resolveTargets
 815           selectPackageTargets
 816           selectComponentTarget
 817           elaboratedPlan
 818           Nothing
 819           targetSelectors
 820
 821     let prunedToTargetsElaboratedPlan =
 822           pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
 823     prunedElaboratedPlan <-
 824       if buildSettingOnlyDeps (buildSettings baseCtx)
 825         then
 826           either (reportCannotPruneDependencies verbosity) return $
 827             pruneInstallPlanToDependencies
 828               (Map.keysSet targets)
 829               prunedToTargetsElaboratedPlan
 830         else return prunedToTargetsElaboratedPlan
 831
 832     return (prunedElaboratedPlan, targets)
 833
 834 -- | From an install configuration, prepare the record needed by actions that
 835 -- will either check if an install of a single executable is possible or
 836 -- actually perform its installation.
 837 prepareExeInstall :: InstallCfg -> IO InstallExe
 838 prepareExeInstall
 839   InstallCfg{verbosity, baseCtx, buildCtx, platform, compiler, installConfigFlags, installClientFlags} = do
 840     installPath <- defaultInstallPath
 841     let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
 842
 843         prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix installConfigFlags))
 844         suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix installConfigFlags))
 845
 846         mkUnitBinDir :: UnitId -> FilePath
 847         mkUnitBinDir =
 848           InstallDirs.bindir
 849             . storePackageInstallDirs' storeDirLayout (compilerId compiler)
 850
 851         mkExeName :: UnqualComponentName -> FilePath
 852         mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
 853
 854         mkFinalExeName :: UnqualComponentName -> FilePath
 855         mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform
 856         installdirUnknown =
 857           "installdir is not defined. Set it in your cabal config file "
 858             ++ "or use --installdir=<path>. Using default installdir: "
 859             ++ show installPath
 860
 861     installdir <-
 862       fromFlagOrDefault
 863         (warn verbosity installdirUnknown >> pure installPath)
 864         $ pure <$> cinstInstalldir installClientFlags
 865     createDirectoryIfMissingVerbose verbosity True installdir
 866     warnIfNoExes verbosity buildCtx
 867
 868     -- This is in IO as we will make environment checks, to decide which install
 869     -- method is best.
 870     let defaultMethod :: IO InstallMethod
 871         defaultMethod
 872           -- Try symlinking in temporary directory, if it works default to
 873           -- symlinking even on windows.
 874           | buildOS == Windows = do
 875               symlinks <- trySymlink verbosity
 876               return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
 877           | otherwise = return InstallMethodSymlink
 878
 879     installMethod <- flagElim defaultMethod return $ cinstInstallMethod installClientFlags
 880
 881     return $ InstallExe installMethod installdir mkUnitBinDir mkExeName mkFinalExeName
 882
 883 -- | Install any built library by adding it to the default ghc environment
 884 installLibraries
 885   :: Verbosity
 886   -> ProjectBuildContext
 887   -> PI.PackageIndex InstalledPackageInfo
 888   -> Compiler
 889   -> PackageDBStack
 890   -> FilePath
 891   -- ^ Environment file
 892   -> [GhcEnvironmentFileEntry]
 893   -> IO ()
 894 installLibraries
 895   verbosity
 896   buildCtx
 897   installedIndex
 898   compiler
 899   packageDbs'
 900   envFile
 901   envEntries = do
 902     if supportsPkgEnvFiles $ getImplInfo compiler
 903       then do
 904         let validDb (SpecificPackageDB fp) = doesPathExist fp
 905             validDb _ = pure True
 906         -- if a user "installs" a global package and no existing cabal db exists, none will be created.
 907         -- this ensures we don't add the "phantom" path to the file.
 908         packageDbs <- filterM validDb packageDbs'
 909         let
 910           getLatest =
 911             (=<<) (maybeToList . safeHead . snd)
 912               . take 1
 913               . sortBy (comparing (Down . fst))
 914               . PI.lookupPackageName installedIndex
 915           globalLatest = concat (getLatest <$> globalPackages)
 916           globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest
 917           baseEntries =
 918             GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs
 919           pkgEntries =
 920             ordNub $
 921               globalEntries
 922                 ++ envEntries
 923                 ++ entriesForLibraryComponents (targetsMap buildCtx)
 924           contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
 925         createDirectoryIfMissing True (takeDirectory envFile)
 926         writeFileAtomic envFile (BS.pack contents')
 927       else
 928         warn verbosity $
 929           "The current compiler doesn't support safely installing libraries, "
 930             ++ "so only executables will be available. (Library installation is "
 931             ++ "supported on GHC 8.0+ only)"
 932
 933 -- See ticket #8894. This is safe to include any nonreinstallable boot pkg,
 934 -- but the particular package users will always expect to be in scope without specific installation
 935 -- is base, so that they can access prelude, regardles of if they specifically asked for it.
 936 globalPackages :: [PackageName]
 937 globalPackages = mkPackageName <$> ["base"]
 938
 939 warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()
 940 warnIfNoExes verbosity buildCtx =
 941   when noExes $
 942     warn verbosity $
 943       "\n"
 944         <> "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
 945         <> "@ WARNING: Installation might not be completed as desired! @\n"
 946         <> "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
 947         <> "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n"
 948         <> "* You might have wanted to add them as dependencies to your package."
 949         <> " In this case add \""
 950         <> intercalate ", " (showTargetSelector <$> selectors)
 951         <> "\" to the build-depends field(s) of your package's .cabal file.\n"
 952         <> "* You might have wanted to add them to a GHC environment. In this case"
 953         <> " use \"cabal install --lib "
 954         <> unwords (showTargetSelector <$> selectors)
 955         <> "\". "
 956         <> " The \"--lib\" flag is provisional: see"
 957         <> " https://github.com/haskell/cabal/issues/6481 for more information."
 958   where
 959     targets = concat $ Map.elems $ targetsMap buildCtx
 960     components = fst <$> targets
 961     selectors = concatMap (NE.toList . snd) targets
 962     noExes = null $ catMaybes $ exeMaybe <$> components
 963
 964     exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
 965     exeMaybe _ = Nothing
 966
 967 -- | Return the package specifiers and non-global environment file entries.
 968 getEnvSpecsAndNonGlobalEntries
 969   :: PI.InstalledPackageIndex
 970   -> [GhcEnvironmentFileEntry]
 971   -> Bool
 972   -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
 973 getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =
 974   if installLibs
 975     then (envSpecs, envEntries')
 976     else ([], envEntries')
 977   where
 978     (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries
 979
 980 environmentFileToSpecifiers
 981   :: PI.InstalledPackageIndex
 982   -> [GhcEnvironmentFileEntry]
 983   -> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
 984 environmentFileToSpecifiers ipi = foldMap $ \case
 985   (GhcEnvFilePackageId unitId)
 986     | Just
 987         InstalledPackageInfo
 988           { sourcePackageId = PackageIdentifier{..}
 989           , installedUnitId
 990           } <-
 991         PI.lookupUnitId ipi unitId
 992     , let pkgSpec =
 993             NamedPackage
 994               pkgName
 995               [PackagePropertyVersion (thisVersion pkgVersion)] ->
 996         ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)])
 997   _ -> ([], [])
 998
 999 -- | Disables tests and benchmarks if they weren't explicitly enabled.
1000 disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
1001 disableTestsBenchsByDefault configFlags =
1002   configFlags
1003     { configTests = Flag False <> configTests configFlags
1004     , configBenchmarks = Flag False <> configBenchmarks configFlags
1005     }
1006
1007 -- | Prepares a record containing the information needed to either symlink or
1008 -- copy an executable.
1009 symlink :: OverwritePolicy -> InstallExe -> UnitId -> UnqualComponentName -> Symlink
1010 symlink
1011   overwritePolicy
1012   InstallExe{installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
1013   unit
1014   exe =
1015     Symlink
1016       overwritePolicy
1017       installDir
1018       (mkSourceBinDir unit)
1019       (mkExeName exe)
1020       (mkFinalExeName exe)
1021
1022 -- |
1023 -- -- * When 'InstallCheckOnly', warn if install would fail overwrite policy
1024 --      checks but don't install anything.
1025 -- -- * When 'InstallCheckInstall', try to symlink or copy every package exe
1026 --      from the store to a given location. When not permitted by the overwrite
1027 --      policy, stop with a message.
1028 installCheckUnitExes :: InstallCheck -> InstallAction
1029 installCheckUnitExes
1030   installCheck
1031   verbosity
1032   overwritePolicy
1033   installExe@InstallExe{installMethod, installDir, mkSourceBinDir, mkExeName, mkFinalExeName}
1034   (unit, components) = do
1035     symlinkables :: [Bool] <- traverse (symlinkableBinary . symlink overwritePolicy installExe unit) exes
1036     case installCheck of
1037       InstallCheckOnly -> traverse_ warnAbout (zip symlinkables exes)
1038       InstallCheckInstall ->
1039         if and symlinkables
1040           then traverse_ installAndWarn exes
1041           else traverse_ warnAbout (zip symlinkables exes)
1042     where
1043       exes = catMaybes $ (exeMaybe . fst) <$> components
1044       exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
1045       exeMaybe _ = Nothing
1046
1047       warnAbout (True, _) = return ()
1048       warnAbout (False, exe) = dieWithException verbosity $ InstallUnitExes (errorMessage installDir exe)
1049
1050       installAndWarn exe = do
1051         success <-
1052           installBuiltExe
1053             verbosity
1054             overwritePolicy
1055             (mkSourceBinDir unit)
1056             (mkExeName exe)
1057             (mkFinalExeName exe)
1058             installDir
1059             installMethod
1060         unless success $ dieWithException verbosity $ InstallUnitExes (errorMessage installDir exe)
1061
1062       errorMessage installdir exe = case overwritePolicy of
1063         NeverOverwrite ->
1064           "Path '"
1065             <> (installdir </> prettyShow exe)
1066             <> "' already exists. "
1067             <> "Use --overwrite-policy=always to overwrite."
1068         -- This shouldn't even be possible, but we keep it in case symlinking or
1069         -- copying logic changes.
1070         _ ->
1071           case installMethod of
1072             InstallMethodSymlink -> "Symlinking"
1073             InstallMethodCopy -> "Copying" <> " '" <> prettyShow exe <> "' failed."
1074
1075 -- | Install a specific exe.
1076 installBuiltExe
1077   :: Verbosity
1078   -> OverwritePolicy
1079   -> FilePath
1080   -- ^ The directory where the built exe is located
1081   -> FilePath
1082   -- ^ The exe's filename
1083   -> FilePath
1084   -- ^ The exe's filename in the public install directory
1085   -> FilePath
1086   -- ^ the directory where it should be installed
1087   -> InstallMethod
1088   -> IO Bool
1089   -- ^ Whether the installation was successful
1090 installBuiltExe
1091   verbosity
1092   overwritePolicy
1093   sourceDir
1094   exeName
1095   finalExeName
1096   installdir
1097   InstallMethodSymlink = do
1098     notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"
1099     symlinkBinary
1100       ( Symlink
1101           overwritePolicy
1102           installdir
1103           sourceDir
1104           finalExeName
1105           exeName
1106       )
1107     where
1108       destination = installdir </> finalExeName
1109 installBuiltExe
1110   verbosity
1111   overwritePolicy
1112   sourceDir
1113   exeName
1114   finalExeName
1115   installdir
1116   InstallMethodCopy = do
1117     notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"
1118     exists <- doesPathExist destination
1119     case (exists, overwritePolicy) of
1120       (True, NeverOverwrite) -> pure False
1121       (True, AlwaysOverwrite) -> overwrite
1122       (True, PromptOverwrite) -> maybeOverwrite
1123       (False, _) -> copy
1124     where
1125       source = sourceDir </> exeName
1126       destination = installdir </> finalExeName
1127       remove = do
1128         isDir <- doesDirectoryExist destination
1129         if isDir
1130           then removeDirectory destination
1131           else removeFile destination
1132       copy = copyFile source destination >> pure True
1133       overwrite :: IO Bool
1134       overwrite = remove >> copy
1135       maybeOverwrite :: IO Bool
1136       maybeOverwrite =
1137         promptRun
1138           "Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
1139           overwrite
1140
1141 -- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
1142 entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
1143 entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
1144   where
1145     hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool
1146     hasLib (ComponentTarget (CLibName _) _, _) = True
1147     hasLib _ = False
1148
1149     go
1150       :: UnitId
1151       -> [(ComponentTarget, NonEmpty TargetSelector)]
1152       -> [GhcEnvironmentFileEntry]
1153     go unitId targets
1154       | any hasLib targets = [GhcEnvFilePackageId unitId]
1155       | otherwise = []
1156
1157 -- | Gets the file path to the request environment file.
1158 getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
1159 getEnvFile clientInstallFlags platform compilerVersion = do
1160   appDir <- getGhcAppDir
1161   case flagToMaybe (cinstEnvironmentPath clientInstallFlags) of
1162     Just spec
1163       -- Is spec a bare word without any "pathy" content, then it refers to
1164       -- a named global environment.
1165       | takeBaseName spec == spec ->
1166           return (getGlobalEnv appDir platform compilerVersion spec)
1167       | otherwise -> do
1168           spec' <- makeAbsolute spec
1169           isDir <- doesDirectoryExist spec'
1170           if isDir
1171             then -- If spec is a directory, then make an ambient environment inside
1172             -- that directory.
1173               return (getLocalEnv spec' platform compilerVersion)
1174             else -- Otherwise, treat it like a literal file path.
1175               return spec'
1176     Nothing ->
1177       return (getGlobalEnv appDir platform compilerVersion "default")
1178
1179 -- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the
1180 --   environment being operated on.
1181 getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]
1182 getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do
1183   envFileExists <- doesFileExist envFile
1184   filterEnvEntries
1185     <$> if (compilerFlavor == GHC || compilerFlavor == GHCJS)
1186       && supportsPkgEnvFiles
1187       && envFileExists
1188       then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
1189         warn
1190           verbosity
1191           ( "The environment file "
1192               ++ envFile
1193               ++ " is unparsable. Libraries cannot be installed."
1194           )
1195           >> return []
1196       else return []
1197   where
1198     -- Why? We know what the first part will be, we only care about the packages.
1199     filterEnvEntries = filter $ \case
1200       GhcEnvFilePackageId _ -> True
1201       _ -> False
1202
1203 -- | Constructs the path to the global GHC environment file.
1204 --
1205 -- TODO(m-renaud): Create PkgEnvName newtype wrapper.
1206 getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath
1207 getGlobalEnv appDir platform compilerVersion name =
1208   appDir
1209     </> ghcPlatformAndVersionString platform compilerVersion
1210     </> "environments"
1211     </> name
1212
1213 -- | Constructs the path to a local GHC environment file.
1214 getLocalEnv :: FilePath -> Platform -> Version -> FilePath
1215 getLocalEnv dir platform compilerVersion =
1216   dir
1217     </> ".ghc.environment."
1218     <> ghcPlatformAndVersionString platform compilerVersion
1219
1220 getPackageDbStack
1221   :: CompilerId
1222   -> Flag FilePath
1223   -> Flag FilePath
1224   -> IO PackageDBStack
1225 getPackageDbStack compilerId storeDirFlag logsDirFlag = do
1226   mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
1227   let
1228     mlogsDir = flagToMaybe logsDirFlag
1229   cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
1230   pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId
1231
1232 -- | This defines what a 'TargetSelector' means for the @bench@ command.
1233 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
1234 -- or otherwise classifies the problem.
1235 --
1236 -- For the @build@ command select all components except non-buildable
1237 -- and disabled tests\/benchmarks, fail if there are no such
1238 -- components
1239 selectPackageTargets
1240   :: TargetSelector
1241   -> [AvailableTarget k]
1242   -> Either TargetProblem' [k]
1243 selectPackageTargets targetSelector targets
1244   -- If there are any buildable targets then we select those
1245   | not (null targetsBuildable) =
1246       Right targetsBuildable
1247   -- If there are targets but none are buildable then we report those
1248   | not (null targets) =
1249       Left (TargetProblemNoneEnabled targetSelector targets')
1250   -- If there are no targets at all then we report that
1251   | otherwise =
1252       Left (TargetProblemNoTargets targetSelector)
1253   where
1254     targets' = forgetTargetsDetail targets
1255     targetsBuildable =
1256       selectBuildableTargetsWith
1257         (buildable targetSelector)
1258         targets
1259
1260     -- When there's a target filter like "pkg:tests" then we do select tests,
1261     -- but if it's just a target like "pkg" then we don't build tests unless
1262     -- they are requested by default (i.e. by using --enable-tests)
1263     buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
1264     buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
1265     buildable _ _ = True
1266
1267 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
1268 -- selected.
1269 --
1270 -- For the @build@ command we just need the basic checks on being buildable etc.
1271 selectComponentTarget
1272   :: SubComponentTarget
1273   -> AvailableTarget k
1274   -> Either TargetProblem' k
1275 selectComponentTarget = selectComponentTargetBasic
1276
1277 reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
1278 reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "build" problems
1279
1280 reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
1281 reportCannotPruneDependencies verbosity =
1282   dieWithException verbosity . SelectComponentTargetError . renderCannotPruneDependencies