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

-- | cabal-install CLI command: build
--
module Distribution.Client.CmdInstall (
    -- * The @build@ CLI and action
    installCommand,
    installAction,

    -- * Internals exposed for testing
    selectPackageTargets,
    selectComponentTarget,
    -- * Internals exposed for CmdRepl + CmdRun
    establishDummyDistDirLayout,
    establishDummyProjectBaseContext
  ) where

import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
         ( doesPathExist )

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

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

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

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

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

  , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ClientInstallFlags)]
commandOptions      = (ShowOrParseArgs -> [OptionField ClientInstallFlags])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags ClientInstallFlags)]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions
  , commandDefaultFlags :: NixStyleFlags ClientInstallFlags
commandDefaultFlags = ClientInstallFlags -> NixStyleFlags ClientInstallFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ClientInstallFlags
defaultClientInstallFlags
  }

-- | 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
-> [String] -> GlobalFlags -> IO ()
installAction flags :: NixStyleFlags ClientInstallFlags
flags@NixStyleFlags { extraFlags :: forall a. NixStyleFlags a -> a
extraFlags = ClientInstallFlags
clientInstallFlags', ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
.. } [String]
targetStrings GlobalFlags
globalFlags = do
  -- Ensure there were no invalid configuration options specified.
  Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
configFlags'

  -- We cannot use establishDummyProjectBaseContext to get these flags, since
  -- it requires one of them as an argument. Normal establishProjectBaseContext
  -- does not, and this is why this is done only for the install command
  ClientInstallFlags
clientInstallFlags <- Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
clientInstallFlags'

  let
    installLibs :: Bool
installLibs    = Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientInstallFlags -> Flag Bool
cinstInstallLibs ClientInstallFlags
clientInstallFlags)
    targetFilter :: Maybe ComponentKind
targetFilter   = if Bool
installLibs then ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
LibKind else ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
ExeKind
    targetStrings' :: [String]
targetStrings' = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
targetStrings then [String
"."] else [String]
targetStrings

    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
    withProject :: IO
  ([PackageSpecifier UnresolvedSourcePackage], [URI],
   [TargetSelector], ProjectConfig)
withProject = do
      let reducedVerbosity :: Verbosity
reducedVerbosity = Verbosity -> Verbosity
lessVerbose Verbosity
verbosity

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

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

      if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
targetStrings'
        then ([PackageSpecifier UnresolvedSourcePackage], [URI],
 [TargetSelector], ProjectConfig)
-> IO
     ([PackageSpecifier UnresolvedSourcePackage], [URI],
      [TargetSelector], ProjectConfig)
forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
forall pkg. [PackageSpecifier pkg]
packageSpecifiers, [], [TargetSelector]
packageTargets, ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
localBaseCtx)
        else do
          [TargetSelector]
targetSelectors <-
            ([TargetSelectorProblem] -> IO [TargetSelector])
-> ([TargetSelector] -> IO [TargetSelector])
-> Either [TargetSelectorProblem] [TargetSelector]
-> IO [TargetSelector]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetSelectorProblem] -> IO [TargetSelector]
forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) [TargetSelector] -> IO [TargetSelector]
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Either [TargetSelectorProblem] [TargetSelector]
 -> IO [TargetSelector])
-> IO (Either [TargetSelectorProblem] [TargetSelector])
-> IO [TargetSelector]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [PackageSpecifier UnresolvedSourcePackage]
-> Maybe ComponentKind
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx)
                                    Maybe ComponentKind
forall a. Maybe a
Nothing [String]
targetStrings''

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

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

    withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)
    withoutProject :: ProjectConfig
-> IO
     ([PackageSpecifier pkg], [URI], [TargetSelector], ProjectConfig)
withoutProject ProjectConfig
globalConfig = do
      [WithoutProjectTargetSelector]
tss <- (String -> IO WithoutProjectTargetSelector)
-> [String] -> IO [WithoutProjectTargetSelector]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity -> String -> IO WithoutProjectTargetSelector
parseWithoutProjectTargetSelector Verbosity
verbosity) [String]
targetStrings'

      String
cabalDir <- IO String
getCabalDir
      let
        projectConfig :: ProjectConfig
projectConfig = ProjectConfig
globalConfig ProjectConfig -> ProjectConfig -> ProjectConfig
forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig

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

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

        mlogsDir :: Maybe String
mlogsDir = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigLogsDir
        mstoreDir :: Maybe String
mstoreDir = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
projectConfigStoreDir
        cabalDirLayout :: CabalDirLayout
cabalDirLayout = String -> Maybe String -> Maybe String -> CabalDirLayout
mkCabalDirLayout String
cabalDir Maybe String
mstoreDir Maybe String
mlogsDir

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    ProjectBuildContext
buildCtx <- Verbosity
-> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext
constructProjectBuildContext Verbosity
verbosity ProjectBaseContext
baseCtx [TargetSelector]
targetSelectors

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

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

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

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

-- | Verify that invalid config options were not passed to the install command.
--
-- If an invalid configuration is found the command will @die'@.
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
configFlags = do
  -- We never try to build tests/benchmarks for remote packages.
  -- So we set them as disabled by default and error if they are explicitly
  -- enabled.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--enable-tests was specified, but tests can't "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"be enabled in a remote package"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--enable-benchmarks was specified, but benchmarks can't "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"be enabled in a remote package"

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


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

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

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

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

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

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

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

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

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

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

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

-- | Partitions the target selectors into known local targets and hackage packages.
partitionToKnownTargetsAndHackagePackages
  :: Verbosity
  -> SourcePackageDb
  -> ElaboratedInstallPlan
  -> [TargetSelector]
  -> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages :: Verbosity
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages Verbosity
verbosity SourcePackageDb
pkgDb ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors = do
  let mTargets :: Either [TargetProblem Void] TargetsMap
mTargets = (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem Void) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem Void) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem Void] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
        forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
        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 (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 (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
-> String -> [(PackageName, [UnresolvedSourcePackage])]
forall pkg. PackageIndex pkg -> String -> [(PackageName, [pkg])]
searchByName (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
pkgDb) (PackageName -> String
unPackageName PackageName
hn) of
            [] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            [(PackageName, [UnresolvedSourcePackage])]
xs -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
              [ String
"Unknown package \"", PackageName -> String
unPackageName PackageName
hn, String
"\". "
              , String
"Did you mean any of the following?\n"
              , [String] -> String
unlines ((String
"- " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((PackageName, [UnresolvedSourcePackage]) -> String)
-> (PackageName, [UnresolvedSourcePackage])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName (PackageName -> String)
-> ((PackageName, [UnresolvedSourcePackage]) -> PackageName)
-> (PackageName, [UnresolvedSourcePackage])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PackageName, [UnresolvedSourcePackage]) -> PackageName
forall a b. (a, b) -> a
fst ((PackageName, [UnresolvedSourcePackage]) -> String)
-> [(PackageName, [UnresolvedSourcePackage])] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
              ]
        TargetProblem Void
_ -> () -> IO ()
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 (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
          TargetPackageNamed PackageName
name Maybe ComponentKind
_
            | PackageName
name PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
          TargetSelector
_                            -> Bool
True

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

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



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

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

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


-- | Install any built exe by symlinking/copying it
-- we don't use BuildOutcomes because we also need the component names
installExes
  :: Verbosity
  -> ProjectBaseContext
  -> ProjectBuildContext
  -> Platform
  -> Compiler
  -> ConfigFlags
  -> ClientInstallFlags
  -> IO ()
installExes :: Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx Platform
platform Compiler
compiler
            ConfigFlags
configFlags ClientInstallFlags
clientInstallFlags = do
  String
installPath <- IO String
defaultInstallPath
  let storeDirLayout :: StoreDirLayout
storeDirLayout = CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout (CabalDirLayout -> StoreDirLayout)
-> CabalDirLayout -> StoreDirLayout
forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx

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

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

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

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

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

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

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

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

-- | Install any built library by adding it to the default ghc environment
installLibraries
  :: Verbosity
  -> ProjectBuildContext
  -> Compiler
  -> PackageDBStack
  -> ProgramDb
  -> FilePath -- ^ Environment file
  -> [GhcEnvironmentFileEntry]
  -> IO ()
installLibraries :: Verbosity
-> ProjectBuildContext
-> Compiler
-> PackageDBStack
-> ProgramDb
-> String
-> [GhcEnvironmentFileEntry]
-> IO ()
installLibraries Verbosity
verbosity ProjectBuildContext
buildCtx Compiler
compiler
                 PackageDBStack
packageDbs ProgramDb
programDb String
envFile [GhcEnvironmentFileEntry]
envEntries = do
  -- Why do we get it again? If we updated a globalPackage then we need
  -- the new version.
  InstalledPackageIndex
installedIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
compiler PackageDBStack
packageDbs ProgramDb
programDb
  if GhcImplInfo -> Bool
supportsPkgEnvFiles (GhcImplInfo -> Bool) -> GhcImplInfo -> Bool
forall a b. (a -> b) -> a -> b
$ Compiler -> GhcImplInfo
getImplInfo Compiler
compiler
    then do
      let
        getLatest :: PackageName -> [InstalledPackageInfo]
        getLatest :: PackageName -> [InstalledPackageInfo]
getLatest = ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> [(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (Maybe InstalledPackageInfo -> [InstalledPackageInfo]
forall a. Maybe a -> [a]
maybeToList (Maybe InstalledPackageInfo -> [InstalledPackageInfo])
-> ((Version, [InstalledPackageInfo])
    -> Maybe InstalledPackageInfo)
-> (Version, [InstalledPackageInfo])
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> Maybe InstalledPackageInfo
forall a. [a] -> Maybe a
safeHead ([InstalledPackageInfo] -> Maybe InstalledPackageInfo)
-> ((Version, [InstalledPackageInfo]) -> [InstalledPackageInfo])
-> (Version, [InstalledPackageInfo])
-> Maybe InstalledPackageInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> [InstalledPackageInfo]
forall a b. (a, b) -> b
snd) ([(Version, [InstalledPackageInfo])] -> [InstalledPackageInfo])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [(Version, [InstalledPackageInfo])]
-> [(Version, [InstalledPackageInfo])]
forall a. Int -> [a] -> [a]
take Int
1 ([(Version, [InstalledPackageInfo])]
 -> [(Version, [InstalledPackageInfo])])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [(Version, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version, [InstalledPackageInfo])
 -> (Version, [InstalledPackageInfo]) -> Ordering)
-> [(Version, [InstalledPackageInfo])]
-> [(Version, [InstalledPackageInfo])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Version, [InstalledPackageInfo]) -> Down Version)
-> (Version, [InstalledPackageInfo])
-> (Version, [InstalledPackageInfo])
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Version -> Down Version
forall a. a -> Down a
Down (Version -> Down Version)
-> ((Version, [InstalledPackageInfo]) -> Version)
-> (Version, [InstalledPackageInfo])
-> Down Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version, [InstalledPackageInfo]) -> Version
forall a b. (a, b) -> a
fst))
                  ([(Version, [InstalledPackageInfo])]
 -> [(Version, [InstalledPackageInfo])])
-> (PackageName -> [(Version, [InstalledPackageInfo])])
-> PackageName
-> [(Version, [InstalledPackageInfo])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PI.lookupPackageName InstalledPackageIndex
installedIndex
        globalLatest :: [InstalledPackageInfo]
globalLatest = [[InstalledPackageInfo]] -> [InstalledPackageInfo]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PackageName -> [InstalledPackageInfo]
getLatest (PackageName -> [InstalledPackageInfo])
-> [PackageName] -> [[InstalledPackageInfo]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
globalPackages)

        baseEntries :: [GhcEnvironmentFileEntry]
baseEntries =
          GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack GhcEnvironmentFileEntry
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. a -> [a] -> [a]
: (PackageDB -> GhcEnvironmentFileEntry)
-> PackageDBStack -> [GhcEnvironmentFileEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb PackageDBStack
packageDbs
        globalEntries :: [GhcEnvironmentFileEntry]
globalEntries = UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId (UnitId -> GhcEnvironmentFileEntry)
-> (InstalledPackageInfo -> UnitId)
-> InstalledPackageInfo
-> GhcEnvironmentFileEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
installedUnitId (InstalledPackageInfo -> GhcEnvironmentFileEntry)
-> [InstalledPackageInfo] -> [GhcEnvironmentFileEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstalledPackageInfo]
globalLatest
        pkgEntries :: [GhcEnvironmentFileEntry]
pkgEntries = [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. Ord a => [a] -> [a]
ordNub ([GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry])
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> a -> b
$
              [GhcEnvironmentFileEntry]
globalEntries
          [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
envEntries
          [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents (ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx)
        contents' :: String
contents' = [GhcEnvironmentFileEntry] -> String
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry]
baseEntries [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
pkgEntries)
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
envFile)
      String -> ByteString -> IO ()
writeFileAtomic String
envFile (String -> ByteString
BS.pack String
contents')
    else
      Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"The current compiler doesn't support safely installing libraries, "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"so only executables will be available. (Library installation is "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"supported on GHC 8.0+ only)"

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 -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"@ WARNING: Installation might not be completed as desired! @\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"* You might have wanted to add them as dependencies to your package." String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" In this case add \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (TargetSelector -> String
showTargetSelector (TargetSelector -> String) -> [TargetSelector] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TargetSelector]
selectors) String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"\" to the build-depends field(s) of your package's .cabal file.\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
"* You might have wanted to add them to a GHC environment. In this case" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" use \"cabal install --lib " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    [String] -> String
unwords (TargetSelector -> String
showTargetSelector (TargetSelector -> String) -> [TargetSelector] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TargetSelector]
selectors) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\". " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" The \"--lib\" flag is provisional: see" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
    String
" 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 (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

globalPackages :: [PackageName]
globalPackages :: [PackageName]
globalPackages = String -> PackageName
mkPackageName (String -> PackageName) -> [String] -> [PackageName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  [ String
"ghc", String
"hoopl", String
"bytestring", String
"unix", String
"base", String
"time", String
"hpc", String
"filepath"
  , String
"process", String
"array", String
"integer-gmp", String
"containers", String
"ghc-boot", String
"binary"
  , String
"ghc-prim", String
"ghci", String
"rts", String
"terminfo", String
"transformers", String
"deepseq"
  , String
"ghc-boot-th", String
"pretty", String
"template-haskell", String
"directory", String
"text"
  , String
"bin-package-db"
  ]

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

environmentFileToSpecifiers
  :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]
  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
environmentFileToSpecifiers :: InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
environmentFileToSpecifiers InstalledPackageIndex
ipi = (GhcEnvironmentFileEntry
 -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]))
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((GhcEnvironmentFileEntry
  -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]))
 -> [GhcEnvironmentFileEntry]
 -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]))
-> (GhcEnvironmentFileEntry
    -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]))
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [GhcEnvironmentFileEntry])
forall a b. (a -> b) -> a -> b
$ \case
    (GhcEnvFilePackageId UnitId
unitId)
        | Just InstalledPackageInfo
          { sourcePackageId :: InstalledPackageInfo -> PackageId
sourcePackageId = PackageIdentifier{PackageName
Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageId -> PackageName
pkgVersion :: PackageId -> Version
..}, UnitId
installedUnitId :: UnitId
installedUnitId :: InstalledPackageInfo -> UnitId
installedUnitId }
          <- 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)]
        -> if PackageName
pkgName PackageName -> [PackageName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
globalPackages
          then ([PackageSpecifier a
forall pkg. PackageSpecifier pkg
pkgSpec], [])
          else ([PackageSpecifier a
forall pkg. PackageSpecifier pkg
pkgSpec], [UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId UnitId
installedUnitId])
    GhcEnvironmentFileEntry
_ -> ([], [])


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

-- | Symlink/copy every exe from a package from the store to a given location
installUnitExes
  :: Verbosity
  -> OverwritePolicy -- ^ Whether to overwrite existing files
  -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
                          -- ^ store directory
  -> (UnqualComponentName -> FilePath) -- ^ A function to get an
                                       -- ^ exe's filename
  -> (UnqualComponentName -> FilePath) -- ^ A function to get an
                                       -- ^ exe's final possibly
                                       -- ^ different to the name in the store.
  -> FilePath
  -> InstallMethod
  -> ( UnitId
     , [(ComponentTarget, NonEmpty TargetSelector)] )
  -> IO ()
installUnitExes :: Verbosity
-> OverwritePolicy
-> (UnitId -> String)
-> (UnqualComponentName -> String)
-> (UnqualComponentName -> String)
-> String
-> InstallMethod
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> IO ()
installUnitExes Verbosity
verbosity OverwritePolicy
overwritePolicy
                UnitId -> String
mkSourceBinDir UnqualComponentName -> String
mkExeName UnqualComponentName -> String
mkFinalExeName
                String
installdir InstallMethod
installMethod
                (UnitId
unit, [(ComponentTarget, NonEmpty TargetSelector)]
components) =
  (UnqualComponentName -> IO ()) -> [UnqualComponentName] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ UnqualComponentName -> IO ()
installAndWarn [UnqualComponentName]
exes
  where
    exes :: [UnqualComponentName]
exes = [Maybe UnqualComponentName] -> [UnqualComponentName]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UnqualComponentName] -> [UnqualComponentName])
-> [Maybe UnqualComponentName] -> [UnqualComponentName]
forall a b. (a -> b) -> a -> b
$ (ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget -> Maybe UnqualComponentName)
-> ((ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget)
-> (ComponentTarget, NonEmpty TargetSelector)
-> Maybe UnqualComponentName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ComponentTarget, NonEmpty TargetSelector) -> ComponentTarget
forall a b. (a, b) -> a
fst) ((ComponentTarget, NonEmpty TargetSelector)
 -> Maybe UnqualComponentName)
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [Maybe UnqualComponentName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ComponentTarget, NonEmpty TargetSelector)]
components
    exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = UnqualComponentName -> Maybe UnqualComponentName
forall a. a -> Maybe a
Just UnqualComponentName
exe
    exeMaybe ComponentTarget
_ = Maybe UnqualComponentName
forall a. Maybe a
Nothing
    installAndWarn :: UnqualComponentName -> IO ()
installAndWarn UnqualComponentName
exe = do
      Bool
success <- Verbosity
-> OverwritePolicy
-> String
-> String
-> String
-> String
-> InstallMethod
-> IO Bool
installBuiltExe
                   Verbosity
verbosity OverwritePolicy
overwritePolicy
                   (UnitId -> String
mkSourceBinDir UnitId
unit) (UnqualComponentName -> String
mkExeName UnqualComponentName
exe)
                   (UnqualComponentName -> String
mkFinalExeName UnqualComponentName
exe)
                   String
installdir InstallMethod
installMethod
      let errorMessage :: String
errorMessage = case OverwritePolicy
overwritePolicy of
            OverwritePolicy
NeverOverwrite ->
              String
"Path '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String
installdir String -> String -> String
</> UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
exe) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' already exists. "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Use --overwrite-policy=always to overwrite."
            -- This shouldn't even be possible, but we keep it in case
            -- symlinking/copying logic changes
            OverwritePolicy
_ ->
              case InstallMethod
installMethod of
                InstallMethod
InstallMethodSymlink -> String
"Symlinking"
                InstallMethod
InstallMethodCopy    ->
                  String
"Copying" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
exe String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' failed."
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
errorMessage

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

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

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


-- | Gets the file path to the request environment file.
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO String
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion = do
  String
appDir <- IO String
getGhcAppDir
  case Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe (ClientInstallFlags -> Flag String
cinstEnvironmentPath ClientInstallFlags
clientInstallFlags) of
    Just String
spec
      -- Is spec a bare word without any "pathy" content, then it refers to
      -- a named global environment.
      | String -> String
takeBaseName String
spec String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
spec ->
          String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Platform -> Version -> String -> String
getGlobalEnv String
appDir Platform
platform Version
compilerVersion String
spec)
      | Bool
otherwise                 -> do
        String
spec' <- String -> IO String
makeAbsolute String
spec
        Bool
isDir <- String -> IO Bool
doesDirectoryExist String
spec'
        if Bool
isDir
          -- If spec is a directory, then make an ambient environment inside
          -- that directory.
          then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Platform -> Version -> String
getLocalEnv String
spec' Platform
platform Version
compilerVersion)
          -- Otherwise, treat it like a literal file path.
          else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
spec'
    Maybe String
Nothing                       ->
      String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Platform -> Version -> String -> String
getGlobalEnv String
appDir Platform
platform Version
compilerVersion String
"default")

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

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

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

getPackageDbStack
  :: CompilerId
  -> Flag FilePath
  -> Flag FilePath
  -> IO PackageDBStack
getPackageDbStack :: CompilerId -> Flag String -> Flag String -> IO PackageDBStack
getPackageDbStack CompilerId
compilerId Flag String
storeDirFlag Flag String
logsDirFlag = do
  String
cabalDir <- IO String
getCabalDir
  Maybe String
mstoreDir <- (String -> IO String) -> Maybe String -> IO (Maybe String)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> IO String
makeAbsolute (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
storeDirFlag
  let
    mlogsDir :: Maybe String
mlogsDir    = Flag String -> Maybe String
forall a. Flag a -> Maybe a
flagToMaybe Flag String
logsDirFlag
    cabalLayout :: CabalDirLayout
cabalLayout = String -> Maybe String -> Maybe String -> CabalDirLayout
mkCabalDirLayout String
cabalDir Maybe String
mstoreDir Maybe String
mlogsDir
  PackageDBStack -> IO PackageDBStack
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDBStack -> IO PackageDBStack)
-> PackageDBStack -> IO PackageDBStack
forall a b. (a -> b) -> a -> b
$ StoreDirLayout -> CompilerId -> PackageDBStack
storePackageDBStack (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalLayout) CompilerId
compilerId

-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
--
selectPackageTargets
  :: TargetSelector
  -> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets :: 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 (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 (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets)
  = TargetProblem Void -> Either (TargetProblem Void) [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem Void
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')

    -- If there are no targets at all then we report that
  | Bool
otherwise
  = TargetProblem Void -> Either (TargetProblem Void) [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem Void
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets'         = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    targetsBuildable :: [k]
targetsBuildable = (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith
                         (TargetSelector -> TargetRequested -> Bool
buildable TargetSelector
targetSelector)
                         [AvailableTarget k]
targets

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

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @build@ command we just need the basic checks on being buildable etc.
--
selectComponentTarget
  :: SubComponentTarget
  -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget :: 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 :: Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity [TargetProblem Void]
problems = Verbosity -> String -> [TargetProblem Void] -> IO a
forall a. Verbosity -> String -> [TargetProblem Void] -> IO a
reportTargetProblems Verbosity
verbosity String
"build" [TargetProblem Void]
problems

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