{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.CmdInstall (
installCommand,
installAction,
selectPackageTargets,
selectComponentTarget,
establishDummyDistDirLayout,
establishDummyProjectBaseContext
) where
import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
( doesPathExist )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdSdist
import Distribution.Client.TargetProblem
( TargetProblem', TargetProblem (..) )
import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.CmdInstall.ClientInstallTargetSelector
import Distribution.Client.Setup
( GlobalFlags(..), ConfigFlags(..), InstallFlags(..) )
import Distribution.Client.Types
( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage
, SourcePackageDb(..) )
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Package
( Package(..), PackageName, mkPackageName, unPackageName )
import Distribution.Types.PackageId
( PackageIdentifier(..) )
import Distribution.Client.ProjectConfig
( ProjectPackageLocation(..)
, fetchAndReadSourcePackages
, projectConfigWithBuilderRepoContext
, resolveBuildTimeSettings, withProjectOrGlobalConfig )
import Distribution.Client.NixStyleOptions
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.ProjectFlags (ProjectFlags (..))
import Distribution.Client.ProjectConfig.Types
( ProjectConfig(..), ProjectConfigShared(..)
, ProjectConfigBuildOnly(..), PackageConfig(..)
, MapMappend(..)
, getMapLast, getMapMappend, projectConfigLogsDir
, projectConfigStoreDir, projectConfigBuildOnly
, projectConfigConfigFile )
import Distribution.Simple.Program.Db
( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
, modifyProgramSearchPath )
import Distribution.Simple.BuildPaths
( exeExtension )
import Distribution.Simple.Program.Find
( ProgramSearchPathEntry(..) )
import Distribution.Client.Config
( defaultInstallPath, loadConfig, SavedConfig(..) )
import qualified Distribution.Simple.PackageIndex as PI
import Distribution.Solver.Types.PackageIndex
( lookupPackageName, searchByName )
import Distribution.Types.InstalledPackageInfo
( InstalledPackageInfo(..) )
import Distribution.Types.Version
( Version, nullVersion )
import Distribution.Types.VersionRange
( thisVersion )
import Distribution.Solver.Types.PackageConstraint
( PackageProperty(..) )
import Distribution.Client.IndexUtils
( getSourcePackages, getInstalledPackages )
import Distribution.Client.ProjectPlanning
( storePackageInstallDirs' )
import Distribution.Client.ProjectPlanning.Types
( ElaboratedInstallPlan )
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Client.DistDirLayout
( DistDirLayout(..), mkCabalDirLayout
, cabalStoreDirLayout
, CabalDirLayout(..), StoreDirLayout(..) )
import Distribution.Client.RebuildMonad
( runRebuild )
import Distribution.Client.InstallSymlink
( symlinkBinary, trySymlink, promptRun )
import Distribution.Client.Types.OverwritePolicy
( OverwritePolicy (..) )
import Distribution.Simple.Flag
( fromFlagOrDefault, flagToMaybe, flagElim )
import Distribution.Simple.Setup
( Flag(..), installDirsOptions )
import Distribution.Solver.Types.SourcePackage
( SourcePackage(..) )
import Distribution.Simple.Command
( CommandUI(..), usageAlternatives, optionName )
import Distribution.Simple.Configure
( configCompilerEx )
import Distribution.Simple.Compiler
( Compiler(..), CompilerId(..), CompilerFlavor(..)
, PackageDBStack, PackageDB(..) )
import Distribution.Simple.GHC
( ghcPlatformAndVersionString, getGhcAppDir
, GhcImplInfo(..), getImplInfo
, GhcEnvironmentFileEntry(..)
, renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
import Distribution.System
( Platform , buildOS, OS (Windows) )
import Distribution.Types.UnitId
( UnitId )
import Distribution.Types.UnqualComponentName
( UnqualComponentName, unUnqualComponentName )
import Distribution.Verbosity
( normal, lessVerbose )
import Distribution.Simple.Utils
( wrapText, die', notice, warn
, withTempDirectory, createDirectoryIfMissingVerbose
, ordNub, safeHead )
import Distribution.Utils.Generic
( writeFileAtomic )
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.Ord
( Down(..) )
import qualified Data.Map as Map
import qualified Data.Set as S
import qualified Data.List.NonEmpty as NE
import Distribution.Utils.NubList
( fromNubList )
import Network.URI (URI)
import System.Directory
( doesFileExist, createDirectoryIfMissing
, getTemporaryDirectory, makeAbsolute, doesDirectoryExist
, removeFile, removeDirectory, copyFile )
import System.FilePath
( (</>), (<.>), takeDirectory, takeBaseName )
installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
installCommand = CommandUI
{ commandName :: FilePath
commandName = FilePath
"v2-install"
, commandSynopsis :: FilePath
commandSynopsis = FilePath
"Install packages."
, commandUsage :: FilePath -> FilePath
commandUsage = FilePath -> [FilePath] -> FilePath -> FilePath
usageAlternatives
FilePath
"v2-install" [ FilePath
"[TARGETS] [FLAGS]" ]
, commandDescription :: Maybe (FilePath -> FilePath)
commandDescription = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \FilePath
_ -> FilePath -> FilePath
wrapText forall a b. (a -> b) -> a -> b
$
FilePath
"Installs one or more packages. This is done by installing them "
forall a. [a] -> [a] -> [a]
++ FilePath
"in the store and symlinking/copying the executables in the directory "
forall a. [a] -> [a] -> [a]
++ FilePath
"specified by the --installdir flag (`~/.local/bin/` by default). "
forall a. [a] -> [a] -> [a]
++ FilePath
"If you want the installed executables to be available globally, "
forall a. [a] -> [a] -> [a]
++ FilePath
"make sure that the PATH environment variable contains that directory. "
forall a. [a] -> [a] -> [a]
++ FilePath
"\n\n"
forall a. [a] -> [a] -> [a]
++ FilePath
"If TARGET is a library and --lib (provisional) is used, "
forall a. [a] -> [a] -> [a]
++ FilePath
"it will be added to the global environment. "
forall a. [a] -> [a] -> [a]
++ FilePath
"When doing this, cabal will try to build a plan that includes all "
forall a. [a] -> [a] -> [a]
++ FilePath
"the previously installed libraries. This is currently not implemented."
, commandNotes :: Maybe (FilePath -> FilePath)
commandNotes = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \FilePath
pname ->
FilePath
"Examples:\n"
forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath
pname forall a. [a] -> [a] -> [a]
++ FilePath
" v2-install\n"
forall a. [a] -> [a] -> [a]
++ FilePath
" Install the package in the current directory\n"
forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath
pname forall a. [a] -> [a] -> [a]
++ FilePath
" v2-install pkgname\n"
forall a. [a] -> [a] -> [a]
++ FilePath
" Install the package named pkgname"
forall a. [a] -> [a] -> [a]
++ FilePath
" (fetching it from hackage if necessary)\n"
forall a. [a] -> [a] -> [a]
++ FilePath
" " forall a. [a] -> [a] -> [a]
++ FilePath
pname forall a. [a] -> [a] -> [a]
++ FilePath
" v2-install ./pkgfoo\n"
forall a. [a] -> [a] -> [a]
++ FilePath
" Install the package in the ./pkgfoo directory\n"
, commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ClientInstallFlags)]
commandOptions = \ShowOrParseArgs
x -> forall a. (a -> Bool) -> [a] -> [a]
filter forall {a}. OptionField a -> Bool
notInstallDirOpt forall a b. (a -> b) -> a -> b
$ forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions ShowOrParseArgs
x
, commandDefaultFlags :: NixStyleFlags ClientInstallFlags
commandDefaultFlags = forall a. a -> NixStyleFlags a
defaultNixStyleFlags ClientInstallFlags
defaultClientInstallFlags
}
where
notInstallDirOpt :: OptionField a -> Bool
notInstallDirOpt OptionField a
x = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. OptionField a -> FilePath
optionName OptionField a
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath]
installDirOptNames
installDirOptNames :: [FilePath]
installDirOptNames = forall a b. (a -> b) -> [a] -> [b]
map forall a. OptionField a -> FilePath
optionName [OptionField (InstallDirs (Flag PathTemplate))]
installDirsOptions
installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
installAction :: NixStyleFlags ClientInstallFlags
-> [FilePath] -> GlobalFlags -> IO ()
installAction flags :: NixStyleFlags ClientInstallFlags
flags@NixStyleFlags { extraFlags :: forall a. NixStyleFlags a -> a
extraFlags = ClientInstallFlags
clientInstallFlags', ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
.. } [FilePath]
targetStrings GlobalFlags
globalFlags = do
Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
configFlags'
ClientInstallFlags
clientInstallFlags <- Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
clientInstallFlags'
let
installLibs :: Bool
installLibs = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (ClientInstallFlags -> Flag Bool
cinstInstallLibs ClientInstallFlags
clientInstallFlags)
targetFilter :: Maybe ComponentKind
targetFilter = if Bool
installLibs then forall a. a -> Maybe a
Just ComponentKind
LibKind else forall a. a -> Maybe a
Just ComponentKind
ExeKind
targetStrings' :: [FilePath]
targetStrings' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings then [FilePath
"."] else [FilePath]
targetStrings
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
ProjectBaseContext
localBaseCtx <-
Verbosity
-> ProjectConfig -> CurrentCommand -> IO ProjectBaseContext
establishProjectBaseContext Verbosity
reducedVerbosity ProjectConfig
cliConfig CurrentCommand
InstallCommand
let localDistDirLayout :: DistDirLayout
localDistDirLayout = ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
localBaseCtx
SourcePackageDb
pkgDb <- forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext Verbosity
reducedVerbosity
(ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
localBaseCtx) (Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity)
let
([FilePath]
targetStrings'', [PackageId]
packageIds) =
forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [FilePath]
targetStrings' forall a b. (a -> b) -> a -> b
$
\FilePath
str -> case forall a. Parsec a => FilePath -> Maybe a
simpleParsec FilePath
str of
Just (PackageId
pkgId :: PackageId)
| PackageId -> Version
pkgVersion PackageId
pkgId forall a. Eq a => a -> a -> Bool
/= Version
nullVersion -> forall a b. b -> Either a b
Right PackageId
pkgId
Maybe PackageId
_ -> forall a b. a -> Either a b
Left FilePath
str
packageSpecifiers :: [PackageSpecifier pkg]
packageSpecifiers =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [PackageId]
packageIds forall a b. (a -> b) -> a -> b
$ \case
PackageIdentifier{PackageName
Version
pkgName :: PackageId -> PackageName
pkgVersion :: Version
pkgName :: PackageName
pkgVersion :: PackageId -> Version
..}
| Version
pkgVersion forall a. Eq a => a -> a -> Bool
== Version
nullVersion -> forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName []
| Bool
otherwise -> forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName
[VersionRange -> PackageProperty
PackagePropertyVersion
(Version -> VersionRange
thisVersion Version
pkgVersion)]
packageTargets :: [TargetSelector]
packageTargets =
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed Maybe ComponentKind
targetFilter forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
pkgName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageId]
packageIds
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings''
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers, [], [TargetSelector]
packageTargets, ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
localBaseCtx)
else do
[TargetSelector]
targetSelectors <-
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [FilePath]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx)
forall a. Maybe a
Nothing [FilePath]
targetStrings''
([PackageSpecifier UnresolvedSourcePackage]
specs, [TargetSelector]
selectors) <-
Verbosity
-> Verbosity
-> SourcePackageDb
-> [TargetSelector]
-> DistDirLayout
-> ProjectBaseContext
-> Maybe ComponentKind
-> IO
([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors
Verbosity
verbosity Verbosity
reducedVerbosity SourcePackageDb
pkgDb [TargetSelector]
targetSelectors DistDirLayout
localDistDirLayout ProjectBaseContext
localBaseCtx Maybe ComponentKind
targetFilter
forall (m :: * -> *) a. Monad m => a -> m a
return ( [PackageSpecifier UnresolvedSourcePackage]
specs forall a. [a] -> [a] -> [a]
++ forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers
, []
, [TargetSelector]
selectors forall a. [a] -> [a] -> [a]
++ [TargetSelector]
packageTargets
, ProjectBaseContext -> ProjectConfig
projectConfig ProjectBaseContext
localBaseCtx )
withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
withoutProject :: ProjectConfig
-> IO
([PackageSpecifier UnresolvedSourcePackage], [URI],
[TargetSelector], ProjectConfig)
withoutProject ProjectConfig
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
targetStrings = IO
([PackageSpecifier UnresolvedSourcePackage], [URI],
[TargetSelector], ProjectConfig)
withProject
withoutProject ProjectConfig
globalConfig = do
[WithoutProjectTargetSelector]
tss <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Verbosity -> FilePath -> IO WithoutProjectTargetSelector
parseWithoutProjectTargetSelector Verbosity
verbosity) [FilePath]
targetStrings'
let
projectConfig :: ProjectConfig
projectConfig = ProjectConfig
globalConfig forall a. Semigroup a => a -> a -> a
<> ProjectConfig
cliConfig
ProjectConfigBuildOnly {
Flag FilePath
projectConfigLogsDir :: Flag FilePath
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigLogsDir
} = ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
projectConfig
ProjectConfigShared {
Flag FilePath
projectConfigStoreDir :: Flag FilePath
projectConfigStoreDir :: ProjectConfigShared -> Flag FilePath
projectConfigStoreDir
} = ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
projectConfig
mlogsDir :: Maybe FilePath
mlogsDir = forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigLogsDir
mstoreDir :: Maybe FilePath
mstoreDir = forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigStoreDir
CabalDirLayout
cabalDirLayout <- Maybe FilePath -> Maybe FilePath -> IO CabalDirLayout
mkCabalDirLayout Maybe FilePath
mstoreDir Maybe FilePath
mlogsDir
let
buildSettings :: BuildTimeSettings
buildSettings = Verbosity -> CabalDirLayout -> ProjectConfig -> BuildTimeSettings
resolveBuildTimeSettings
Verbosity
verbosity CabalDirLayout
cabalDirLayout
ProjectConfig
projectConfig
SourcePackageDb { PackageIndex UnresolvedSourcePackage
packageIndex :: SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex :: PackageIndex UnresolvedSourcePackage
packageIndex } <- forall a.
Verbosity -> BuildTimeSettings -> (RepoContext -> IO a) -> IO a
projectConfigWithBuilderRepoContext
Verbosity
verbosity BuildTimeSettings
buildSettings
(Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages Verbosity
verbosity)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WithoutProjectTargetSelector -> [PackageName]
woPackageNames [WithoutProjectTargetSelector]
tss) forall a b. (a -> b) -> a -> b
$ \PackageName
name -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall pkg. Package pkg => PackageIndex pkg -> PackageName -> [pkg]
lookupPackageName PackageIndex UnresolvedSourcePackage
packageIndex PackageName
name)) forall a b. (a -> b) -> a -> b
$ do
let xs :: [(PackageName, [UnresolvedSourcePackage])]
xs = forall pkg. PackageIndex pkg -> FilePath -> [(PackageName, [pkg])]
searchByName PackageIndex UnresolvedSourcePackage
packageIndex (PackageName -> FilePath
unPackageName PackageName
name)
let emptyIf :: Bool -> [a] -> [a]
emptyIf Bool
True [a]
_ = []
emptyIf Bool
False [a]
zs = [a]
zs
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ FilePath
"Unknown package \"", PackageName -> FilePath
unPackageName PackageName
name, FilePath
"\". "
] forall a. [a] -> [a] -> [a]
++ forall {a}. Bool -> [a] -> [a]
emptyIf (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(PackageName, [UnresolvedSourcePackage])]
xs)
[ FilePath
"Did you mean any of the following?\n"
, [FilePath] -> FilePath
unlines ((FilePath
"- " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
]
let
([URI]
uris, [PackageSpecifier pkg]
packageSpecifiers) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall pkg.
WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
woPackageSpecifiers [WithoutProjectTargetSelector]
tss
packageTargets :: [TargetSelector]
packageTargets = forall a b. (a -> b) -> [a] -> [b]
map WithoutProjectTargetSelector -> TargetSelector
woPackageTargets [WithoutProjectTargetSelector]
tss
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {pkg}. [PackageSpecifier pkg]
packageSpecifiers, [URI]
uris, [TargetSelector]
packageTargets, ProjectConfig
projectConfig)
([PackageSpecifier UnresolvedSourcePackage]
specs, [URI]
uris, [TargetSelector]
targetSelectors, ProjectConfig
config) <-
forall a.
Verbosity
-> Flag Bool
-> Flag FilePath
-> IO a
-> (ProjectConfig -> IO a)
-> IO a
withProjectOrGlobalConfig Verbosity
verbosity Flag Bool
ignoreProject Flag FilePath
globalConfigFlag IO
([PackageSpecifier UnresolvedSourcePackage], [URI],
[TargetSelector], ProjectConfig)
withProject ProjectConfig
-> IO
([PackageSpecifier UnresolvedSourcePackage], [URI],
[TargetSelector], ProjectConfig)
withoutProject
let
ProjectConfig {
projectConfigBuildOnly :: ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly = ProjectConfigBuildOnly {
Flag FilePath
projectConfigLogsDir :: Flag FilePath
projectConfigLogsDir :: ProjectConfigBuildOnly -> Flag FilePath
projectConfigLogsDir
},
projectConfigShared :: ProjectConfig -> ProjectConfigShared
projectConfigShared = ProjectConfigShared {
Flag CompilerFlavor
projectConfigHcFlavor :: ProjectConfigShared -> Flag CompilerFlavor
projectConfigHcFlavor :: Flag CompilerFlavor
projectConfigHcFlavor,
Flag FilePath
projectConfigHcPath :: ProjectConfigShared -> Flag FilePath
projectConfigHcPath :: Flag FilePath
projectConfigHcPath,
Flag FilePath
projectConfigHcPkg :: ProjectConfigShared -> Flag FilePath
projectConfigHcPkg :: Flag FilePath
projectConfigHcPkg,
Flag FilePath
projectConfigStoreDir :: Flag FilePath
projectConfigStoreDir :: ProjectConfigShared -> Flag FilePath
projectConfigStoreDir
},
projectConfigLocalPackages :: ProjectConfig -> PackageConfig
projectConfigLocalPackages = PackageConfig {
MapLast FilePath FilePath
packageConfigProgramPaths :: PackageConfig -> MapLast FilePath FilePath
packageConfigProgramPaths :: MapLast FilePath FilePath
packageConfigProgramPaths,
MapMappend FilePath [FilePath]
packageConfigProgramArgs :: PackageConfig -> MapMappend FilePath [FilePath]
packageConfigProgramArgs :: MapMappend FilePath [FilePath]
packageConfigProgramArgs,
NubList FilePath
packageConfigProgramPathExtra :: PackageConfig -> NubList FilePath
packageConfigProgramPathExtra :: NubList FilePath
packageConfigProgramPathExtra
}
} = ProjectConfig
config
hcFlavor :: Maybe CompilerFlavor
hcFlavor = forall a. Flag a -> Maybe a
flagToMaybe Flag CompilerFlavor
projectConfigHcFlavor
hcPath :: Maybe FilePath
hcPath = forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHcPath
hcPkg :: Maybe FilePath
hcPkg = forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
projectConfigHcPkg
preProgDb :: ProgramDb
preProgDb =
[(FilePath, FilePath)] -> ProgramDb -> ProgramDb
userSpecifyPaths (forall k a. Map k a -> [(k, a)]
Map.toList (forall k v. MapLast k v -> Map k v
getMapLast MapLast FilePath FilePath
packageConfigProgramPaths))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, [FilePath])] -> ProgramDb -> ProgramDb
userSpecifyArgss (forall k a. Map k a -> [(k, a)]
Map.toList (forall k v. MapMappend k v -> Map k v
getMapMappend MapMappend FilePath [FilePath]
packageConfigProgramArgs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgramSearchPath -> ProgramSearchPath) -> ProgramDb -> ProgramDb
modifyProgramSearchPath
(forall a. [a] -> [a] -> [a]
++ [ FilePath -> ProgramSearchPathEntry
ProgramSearchPathDir FilePath
dir
| FilePath
dir <- forall a. NubList a -> [a]
fromNubList NubList FilePath
packageConfigProgramPathExtra ])
forall a b. (a -> b) -> a -> b
$ ProgramDb
defaultProgramDb
(compiler :: Compiler
compiler@Compiler { compilerId :: Compiler -> CompilerId
compilerId =
compilerId :: CompilerId
compilerId@(CompilerId CompilerFlavor
compilerFlavor Version
compilerVersion) }, Platform
platform, ProgramDb
progDb) <-
Maybe CompilerFlavor
-> Maybe FilePath
-> Maybe FilePath
-> ProgramDb
-> Verbosity
-> IO (Compiler, Platform, ProgramDb)
configCompilerEx Maybe CompilerFlavor
hcFlavor Maybe FilePath
hcPath Maybe FilePath
hcPkg ProgramDb
preProgDb Verbosity
verbosity
let
GhcImplInfo{ Bool
supportsPkgEnvFiles :: GhcImplInfo -> Bool
supportsPkgEnvFiles :: Bool
supportsPkgEnvFiles } = Compiler -> GhcImplInfo
getImplInfo Compiler
compiler
FilePath
envFile <- ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion
[GhcEnvironmentFileEntry]
existingEnvEntries <-
Verbosity
-> CompilerFlavor
-> Bool
-> FilePath
-> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile
PackageDBStack
packageDbs <- CompilerId -> Flag FilePath -> Flag FilePath -> IO PackageDBStack
getPackageDbStack CompilerId
compilerId Flag FilePath
projectConfigStoreDir Flag FilePath
projectConfigLogsDir
InstalledPackageIndex
installedIndex <- Verbosity
-> Compiler
-> PackageDBStack
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Compiler
compiler PackageDBStack
packageDbs ProgramDb
progDb
let
([PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries) =
forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> Bool
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry]
existingEnvEntries Bool
installLibs
FilePath
globalTmp <- IO FilePath
getTemporaryDirectory
forall a.
Verbosity -> FilePath -> FilePath -> (FilePath -> IO a) -> IO a
withTempDirectory Verbosity
verbosity FilePath
globalTmp FilePath
"cabal-install." forall a b. (a -> b) -> a -> b
$ \FilePath
tmpDir -> do
DistDirLayout
distDirLayout <- Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout Verbosity
verbosity ProjectConfig
config FilePath
tmpDir
[PackageSpecifier UnresolvedSourcePackage]
uriSpecs <- forall a. FilePath -> Rebuild a -> IO a
runRebuild FilePath
tmpDir forall a b. (a -> b) -> a -> b
$ Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> ProjectConfigBuildOnly
-> [ProjectPackageLocation]
-> Rebuild [PackageSpecifier UnresolvedSourcePackage]
fetchAndReadSourcePackages
Verbosity
verbosity
DistDirLayout
distDirLayout
(ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
config)
(ProjectConfig -> ProjectConfigBuildOnly
projectConfigBuildOnly ProjectConfig
config)
[ URI -> ProjectPackageLocation
ProjectPackageRemoteTarball URI
uri | URI
uri <- [URI]
uris ]
let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName (NamedPackage PackageName
pn [PackageProperty]
_) = PackageName
pn
getPackageName (SpecificSourcePackage (SourcePackage PackageId
pkgId GenericPackageDescription
_ UnresolvedPkgLoc
_ PackageDescriptionOverride
_)) = PackageId -> PackageName
pkgName PackageId
pkgId
targetNames :: Set PackageName
targetNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName ([PackageSpecifier UnresolvedSourcePackage]
specs forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
envNames :: Set PackageName
envNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName forall {pkg}. [PackageSpecifier pkg]
envSpecs
forceInstall :: Bool
forceInstall = forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False forall a b. (a -> b) -> a -> b
$ InstallFlags -> Flag Bool
installOverrideReinstall InstallFlags
installFlags
nameIntersection :: Set PackageName
nameIntersection = forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set PackageName
targetNames Set PackageName
envNames
([PackageSpecifier UnresolvedSourcePackage]
envSpecs', [GhcEnvironmentFileEntry]
nonGlobalEnvEntries') <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set PackageName
nameIntersection
then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall {pkg}. [PackageSpecifier pkg]
envSpecs, forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries)
else if Bool
forceInstall
then let es :: [PackageSpecifier UnresolvedSourcePackage]
es = forall a. (a -> Bool) -> [a] -> [a]
filter (\PackageSpecifier UnresolvedSourcePackage
e -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName PackageSpecifier UnresolvedSourcePackage
e forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) forall {pkg}. [PackageSpecifier pkg]
envSpecs
nge :: [GhcEnvironmentFileEntry]
nge = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, GhcEnvironmentFileEntry)
e -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst (PackageName, GhcEnvironmentFileEntry)
e forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
nameIntersection) forall a b. (a -> b) -> a -> b
$ [(PackageName, GhcEnvironmentFileEntry)]
nonGlobalEnvEntries
in forall (f :: * -> *) a. Applicative f => a -> f a
pure ([PackageSpecifier UnresolvedSourcePackage]
es, [GhcEnvironmentFileEntry]
nge)
else forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Packages requested to install already exist in environment file at " forall a. [a] -> [a] -> [a]
++ FilePath
envFile forall a. [a] -> [a] -> [a]
++ FilePath
". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty a => a -> FilePath
prettyShow forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
S.toList Set PackageName
nameIntersection)
let installedPacks :: [(PackageName, [InstalledPackageInfo])]
installedPacks = forall a. PackageIndex a -> [(PackageName, [a])]
PI.allPackagesByName InstalledPackageIndex
installedIndex
newEnvNames :: Set PackageName
newEnvNames = forall a. Ord a => [a] -> Set a
S.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageSpecifier UnresolvedSourcePackage -> PackageName
getPackageName [PackageSpecifier UnresolvedSourcePackage]
envSpecs'
installedIndex' :: InstalledPackageIndex
installedIndex' = [InstalledPackageInfo] -> InstalledPackageIndex
PI.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\(PackageName, [InstalledPackageInfo])
p -> forall a b. (a, b) -> a
fst (PackageName, [InstalledPackageInfo])
p forall a. Ord a => a -> Set a -> Bool
`S.member` Set PackageName
newEnvNames) forall a b. (a -> b) -> a -> b
$ [(PackageName, [InstalledPackageInfo])]
installedPacks
ProjectBaseContext
baseCtx <- Verbosity
-> ProjectConfig
-> DistDirLayout
-> [PackageSpecifier UnresolvedSourcePackage]
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext
Verbosity
verbosity
ProjectConfig
config
DistDirLayout
distDirLayout
([PackageSpecifier UnresolvedSourcePackage]
envSpecs' forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
specs forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
uriSpecs)
CurrentCommand
InstallCommand
ProjectBuildContext
buildCtx <- Verbosity
-> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext
constructProjectBuildContext Verbosity
verbosity (ProjectBaseContext
baseCtx {installedPackages :: Maybe InstalledPackageIndex
installedPackages = forall a. a -> Maybe a
Just InstalledPackageIndex
installedIndex'}) [TargetSelector]
targetSelectors
Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx
BuildOutcomes
buildOutcomes <- Verbosity
-> ProjectBaseContext -> ProjectBuildContext -> IO BuildOutcomes
runProjectBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx
Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> BuildOutcomes
-> IO ()
runProjectPostBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx BuildOutcomes
buildOutcomes
let
dryRun :: Bool
dryRun = BuildTimeSettings -> Bool
buildSettingDryRun (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
Bool -> Bool -> Bool
|| BuildTimeSettings -> Bool
buildSettingOnlyDownload (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun forall a b. (a -> b) -> a -> b
$
if Bool
installLibs
then Verbosity
-> ProjectBuildContext
-> InstalledPackageIndex
-> Compiler
-> PackageDBStack
-> FilePath
-> [GhcEnvironmentFileEntry]
-> IO ()
installLibraries Verbosity
verbosity
ProjectBuildContext
buildCtx InstalledPackageIndex
installedIndex Compiler
compiler PackageDBStack
packageDbs FilePath
envFile [GhcEnvironmentFileEntry]
nonGlobalEnvEntries'
else Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes Verbosity
verbosity
ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx Platform
platform Compiler
compiler ConfigFlags
configFlags ClientInstallFlags
clientInstallFlags
where
configFlags' :: ConfigFlags
configFlags' = ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault ConfigFlags
configFlags
verbosity :: Verbosity
verbosity = forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
normal (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags')
ignoreProject :: Flag Bool
ignoreProject = ProjectFlags -> Flag Bool
flagIgnoreProject ProjectFlags
projectFlags
baseCliConfig :: ProjectConfig
baseCliConfig = forall a.
GlobalFlags
-> NixStyleFlags a -> ClientInstallFlags -> ProjectConfig
commandLineFlagsToProjectConfig
GlobalFlags
globalFlags
NixStyleFlags ClientInstallFlags
flags { configFlags :: ConfigFlags
configFlags = ConfigFlags
configFlags' }
ClientInstallFlags
clientInstallFlags'
cliConfig :: ProjectConfig
cliConfig = ProjectConfig -> [FilePath] -> ProjectConfig
addLocalConfigToTargets ProjectConfig
baseCliConfig [FilePath]
targetStrings
globalConfigFlag :: Flag FilePath
globalConfigFlag = ProjectConfigShared -> Flag FilePath
projectConfigConfigFile (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
cliConfig)
addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig
addLocalConfigToTargets :: ProjectConfig -> [FilePath] -> ProjectConfig
addLocalConfigToTargets ProjectConfig
config [FilePath]
targetStrings
= ProjectConfig
config {
projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
projectConfigSpecificPackage = ProjectConfig -> MapMappend PackageName PackageConfig
projectConfigSpecificPackage ProjectConfig
config
forall a. Semigroup a => a -> a -> a
<> forall k v. Map k v -> MapMappend k v
MapMappend (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(PackageName, PackageConfig)]
targetPackageConfigs)
}
where
localConfig :: PackageConfig
localConfig = ProjectConfig -> PackageConfig
projectConfigLocalPackages ProjectConfig
config
targetPackageConfigs :: [(PackageName, PackageConfig)]
targetPackageConfigs = forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> (FilePath -> PackageName
mkPackageName FilePath
x, PackageConfig
localConfig)) [FilePath]
targetStrings
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie :: Verbosity -> ConfigFlags -> IO ()
verifyPreconditionsOrDie Verbosity
verbosity ConfigFlags
configFlags = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags forall a. Eq a => a -> a -> Bool
== forall a. a -> Flag a
Flag Bool
True) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"--enable-tests was specified, but tests can't "
forall a. [a] -> [a] -> [a]
++ FilePath
"be enabled in a remote package"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags forall a. Eq a => a -> a -> Bool
== forall a. a -> Flag a
Flag Bool
True) forall a b. (a -> b) -> a -> b
$
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"--enable-benchmarks was specified, but benchmarks can't "
forall a. [a] -> [a] -> [a]
++ FilePath
"be enabled in a remote package"
getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags :: Verbosity
-> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags Verbosity
verbosity GlobalFlags
globalFlags ClientInstallFlags
existingClientInstallFlags = do
let configFileFlag :: Flag FilePath
configFileFlag = GlobalFlags -> Flag FilePath
globalConfigFile GlobalFlags
globalFlags
SavedConfig
savedConfig <- Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig Verbosity
verbosity Flag FilePath
configFileFlag
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SavedConfig -> ClientInstallFlags
savedClientInstallFlags SavedConfig
savedConfig forall a. Monoid a => a -> a -> a
`mappend` ClientInstallFlags
existingClientInstallFlags
getSpecsAndTargetSelectors
:: Verbosity
-> Verbosity
-> SourcePackageDb
-> [TargetSelector]
-> DistDirLayout
-> ProjectBaseContext
-> Maybe ComponentKindFilter
-> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors :: Verbosity
-> Verbosity
-> SourcePackageDb
-> [TargetSelector]
-> DistDirLayout
-> ProjectBaseContext
-> Maybe ComponentKind
-> IO
([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors Verbosity
verbosity Verbosity
reducedVerbosity SourcePackageDb
pkgDb [TargetSelector]
targetSelectors DistDirLayout
localDistDirLayout ProjectBaseContext
localBaseCtx Maybe ComponentKind
targetFilter =
forall a.
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
-> IO a
withInstallPlan Verbosity
reducedVerbosity ProjectBaseContext
localBaseCtx forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan ElaboratedSharedConfig
_ -> do
(TargetsMap
targets, [PackageName]
hackageNames) <-
Verbosity
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages
Verbosity
verbosity SourcePackageDb
pkgDb ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors
let
planMap :: Map
UnitId
(GenericPlanPackage
InstalledPackageInfo ElaboratedConfiguredPackage)
planMap = forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
InstallPlan.toMap ElaboratedInstallPlan
elaboratedPlan
targetIds :: [UnitId]
targetIds = forall k a. Map k a -> [k]
Map.keys TargetsMap
targets
sdistize :: PackageSpecifier (SourcePackage (PackageLocation local))
-> PackageSpecifier (SourcePackage (PackageLocation local))
sdistize (SpecificSourcePackage SourcePackage (PackageLocation local)
spkg) =
forall pkg. pkg -> PackageSpecifier pkg
SpecificSourcePackage forall {local}. SourcePackage (PackageLocation local)
spkg'
where
sdistPath :: FilePath
sdistPath = DistDirLayout -> PackageId -> FilePath
distSdistFile DistDirLayout
localDistDirLayout (forall pkg. Package pkg => pkg -> PackageId
packageId SourcePackage (PackageLocation local)
spkg)
spkg' :: SourcePackage (PackageLocation local)
spkg' = SourcePackage (PackageLocation local)
spkg { srcpkgSource :: PackageLocation local
srcpkgSource = forall local. FilePath -> PackageLocation local
LocalTarballPackage FilePath
sdistPath }
sdistize PackageSpecifier (SourcePackage (PackageLocation local))
named = PackageSpecifier (SourcePackage (PackageLocation local))
named
local :: [PackageSpecifier UnresolvedSourcePackage]
local = forall {local}.
PackageSpecifier (SourcePackage (PackageLocation local))
-> PackageSpecifier (SourcePackage (PackageLocation local))
sdistize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx
gatherTargets :: UnitId -> TargetSelector
gatherTargets :: UnitId -> TargetSelector
gatherTargets UnitId
targetId = PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pkgName Maybe ComponentKind
targetFilter
where
targetUnit :: GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
targetUnit = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (forall a. HasCallStack => FilePath -> a
error FilePath
"cannot find target unit") UnitId
targetId Map
UnitId
(GenericPlanPackage
InstalledPackageInfo ElaboratedConfiguredPackage)
planMap
PackageIdentifier{PackageName
Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageId -> PackageName
pkgVersion :: PackageId -> Version
..} = forall pkg. Package pkg => pkg -> PackageId
packageId GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
targetUnit
targets' :: [TargetSelector]
targets' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitId -> TargetSelector
gatherTargets [UnitId]
targetIds
hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
hackageNames
hackageTargets :: [TargetSelector]
hackageTargets :: [TargetSelector]
hackageTargets =
forall a b c. (a -> b -> c) -> b -> a -> c
flip PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed Maybe ComponentKind
targetFilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
hackageNames
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (DistDirLayout -> FilePath
distSdistDirectory DistDirLayout
localDistDirLayout)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall k a. Map k a -> Bool
Map.null TargetsMap
targets) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages ProjectBaseContext
localBaseCtx) forall a b. (a -> b) -> a -> b
$ \PackageSpecifier UnresolvedSourcePackage
lpkg -> case PackageSpecifier UnresolvedSourcePackage
lpkg of
SpecificSourcePackage UnresolvedSourcePackage
pkg -> Verbosity
-> FilePath
-> OutputFormat
-> FilePath
-> UnresolvedSourcePackage
-> IO ()
packageToSdist Verbosity
verbosity
(DistDirLayout -> FilePath
distProjectRootDirectory DistDirLayout
localDistDirLayout) OutputFormat
TarGzArchive
(DistDirLayout -> PackageId -> FilePath
distSdistFile DistDirLayout
localDistDirLayout (forall pkg. Package pkg => pkg -> PackageId
packageId UnresolvedSourcePackage
pkg)) UnresolvedSourcePackage
pkg
NamedPackage PackageName
pkgName [PackageProperty]
_ -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"Got NamedPackage " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> FilePath
prettyShow PackageName
pkgName
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null TargetsMap
targets
then forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
hackagePkgs, [TargetSelector]
hackageTargets)
else forall (m :: * -> *) a. Monad m => a -> m a
return ([PackageSpecifier UnresolvedSourcePackage]
local forall a. [a] -> [a] -> [a]
++ [PackageSpecifier UnresolvedSourcePackage]
hackagePkgs, [TargetSelector]
targets' forall a. [a] -> [a] -> [a]
++ [TargetSelector]
hackageTargets)
partitionToKnownTargetsAndHackagePackages
:: Verbosity
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages :: Verbosity
-> SourcePackageDb
-> ElaboratedInstallPlan
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages Verbosity
verbosity SourcePackageDb
pkgDb ElaboratedInstallPlan
elaboratedPlan [TargetSelector]
targetSelectors = do
let mTargets :: Either [TargetProblem Void] TargetsMap
mTargets = forall err.
(forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
ElaboratedInstallPlan
elaboratedPlan
(forall a. a -> Maybe a
Just SourcePackageDb
pkgDb)
[TargetSelector]
targetSelectors
case Either [TargetProblem Void] TargetsMap
mTargets of
Right TargetsMap
targets ->
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetsMap
targets, [])
Left [TargetProblem Void]
errs -> do
let
([TargetProblem Void]
errs', [PackageName]
hackageNames) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TargetProblem Void]
errs forall a b. (a -> b) -> a -> b
$ \case
TargetAvailableInIndex PackageName
name -> forall a b. b -> Either a b
Right PackageName
name
TargetProblem Void
err -> forall a b. a -> Either a b
Left TargetProblem Void
err
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TargetProblem Void]
errs' forall a b. (a -> b) -> a -> b
$ \case
TargetNotInProject PackageName
hn ->
case forall pkg. PackageIndex pkg -> FilePath -> [(PackageName, [pkg])]
searchByName (SourcePackageDb -> PackageIndex UnresolvedSourcePackage
packageIndex SourcePackageDb
pkgDb) (PackageName -> FilePath
unPackageName PackageName
hn) of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(PackageName, [UnresolvedSourcePackage])]
xs -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ FilePath
"Unknown package \"", PackageName -> FilePath
unPackageName PackageName
hn, FilePath
"\". "
, FilePath
"Did you mean any of the following?\n"
, [FilePath] -> FilePath
unlines ((FilePath
"- " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> FilePath
unPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(PackageName, [UnresolvedSourcePackage])]
xs)
]
TargetProblem Void
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [TargetProblem Void]
errs') forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity [TargetProblem Void]
errs'
let
targetSelectors' :: [TargetSelector]
targetSelectors' = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> [a] -> [a]
filter [TargetSelector]
targetSelectors forall a b. (a -> b) -> a -> b
$ \case
TargetComponentUnknown PackageName
name Either UnqualComponentName ComponentName
_ SubComponentTarget
_
| PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
TargetPackageNamed PackageName
name Maybe ComponentKind
_
| PackageName
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PackageName]
hackageNames -> Bool
False
TargetSelector
_ -> Bool
True
TargetsMap
targets <-
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall err.
(forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
ElaboratedInstallPlan
elaboratedPlan
forall a. Maybe a
Nothing
[TargetSelector]
targetSelectors'
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetsMap
targets, [PackageName]
hackageNames)
constructProjectBuildContext
:: Verbosity
-> ProjectBaseContext
-> [TargetSelector]
-> IO ProjectBuildContext
constructProjectBuildContext :: Verbosity
-> ProjectBaseContext -> [TargetSelector] -> IO ProjectBuildContext
constructProjectBuildContext Verbosity
verbosity ProjectBaseContext
baseCtx [TargetSelector]
targetSelectors = do
Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
-> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
TargetsMap
targets <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall err.
(forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargets
forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets
forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget
ElaboratedInstallPlan
elaboratedPlan
forall a. Maybe a
Nothing
[TargetSelector]
targetSelectors
let prunedToTargetsElaboratedPlan :: ElaboratedInstallPlan
prunedToTargetsElaboratedPlan =
TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets TargetAction
TargetActionBuild TargetsMap
targets ElaboratedInstallPlan
elaboratedPlan
ElaboratedInstallPlan
prunedElaboratedPlan <-
if BuildTimeSettings -> Bool
buildSettingOnlyDeps (ProjectBaseContext -> BuildTimeSettings
buildSettings ProjectBaseContext
baseCtx)
then forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies Verbosity
verbosity) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
Set UnitId
-> ElaboratedInstallPlan
-> Either CannotPruneDependencies ElaboratedInstallPlan
pruneInstallPlanToDependencies (forall k a. Map k a -> Set k
Map.keysSet TargetsMap
targets)
ElaboratedInstallPlan
prunedToTargetsElaboratedPlan
else forall (m :: * -> *) a. Monad m => a -> m a
return ElaboratedInstallPlan
prunedToTargetsElaboratedPlan
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
prunedElaboratedPlan, TargetsMap
targets)
installExes
:: Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes :: Verbosity
-> ProjectBaseContext
-> ProjectBuildContext
-> Platform
-> Compiler
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
installExes Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx Platform
platform Compiler
compiler
ConfigFlags
configFlags ClientInstallFlags
clientInstallFlags = do
FilePath
installPath <- IO FilePath
defaultInstallPath
let storeDirLayout :: StoreDirLayout
storeDirLayout = CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout forall a b. (a -> b) -> a -> b
$ ProjectBaseContext -> CabalDirLayout
cabalDirLayout ProjectBaseContext
baseCtx
prefix :: FilePath
prefix = forall a. a -> Flag a -> a
fromFlagOrDefault FilePath
"" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> FilePath
InstallDirs.fromPathTemplate (ConfigFlags -> Flag PathTemplate
configProgPrefix ConfigFlags
configFlags))
suffix :: FilePath
suffix = forall a. a -> Flag a -> a
fromFlagOrDefault FilePath
"" (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathTemplate -> FilePath
InstallDirs.fromPathTemplate (ConfigFlags -> Flag PathTemplate
configProgSuffix ConfigFlags
configFlags))
mkUnitBinDir :: UnitId -> FilePath
mkUnitBinDir :: UnitId -> FilePath
mkUnitBinDir =
forall dir. InstallDirs dir -> dir
InstallDirs.bindir forall b c a. (b -> c) -> (a -> b) -> a -> c
.
StoreDirLayout -> CompilerId -> UnitId -> InstallDirs FilePath
storePackageInstallDirs' StoreDirLayout
storeDirLayout (Compiler -> CompilerId
compilerId Compiler
compiler)
mkExeName :: UnqualComponentName -> FilePath
mkExeName :: UnqualComponentName -> FilePath
mkExeName UnqualComponentName
exe = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
exe FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension Platform
platform
mkFinalExeName :: UnqualComponentName -> FilePath
mkFinalExeName :: UnqualComponentName -> FilePath
mkFinalExeName UnqualComponentName
exe = FilePath
prefix forall a. Semigroup a => a -> a -> a
<> UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
exe forall a. Semigroup a => a -> a -> a
<> FilePath
suffix FilePath -> FilePath -> FilePath
<.> Platform -> FilePath
exeExtension Platform
platform
installdirUnknown :: FilePath
installdirUnknown =
FilePath
"installdir is not defined. Set it in your cabal config file "
forall a. [a] -> [a] -> [a]
++ FilePath
"or use --installdir=<path>. Using default installdir: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
installPath
FilePath
installdir <- forall a. a -> Flag a -> a
fromFlagOrDefault
(Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity FilePath
installdirUnknown forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure FilePath
installPath) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClientInstallFlags -> Flag FilePath
cinstInstalldir ClientInstallFlags
clientInstallFlags
Verbosity -> Bool -> FilePath -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True FilePath
installdir
Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes Verbosity
verbosity ProjectBuildContext
buildCtx
InstallMethod
installMethod <- forall b a. b -> (a -> b) -> Flag a -> b
flagElim IO InstallMethod
defaultMethod forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
ClientInstallFlags -> Flag InstallMethod
cinstInstallMethod ClientInstallFlags
clientInstallFlags
let
doInstall :: (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
doInstall = Verbosity
-> OverwritePolicy
-> (UnitId -> FilePath)
-> (UnqualComponentName -> FilePath)
-> (UnqualComponentName -> FilePath)
-> FilePath
-> InstallMethod
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> IO ()
installUnitExes
Verbosity
verbosity
OverwritePolicy
overwritePolicy
UnitId -> FilePath
mkUnitBinDir UnqualComponentName -> FilePath
mkExeName UnqualComponentName -> FilePath
mkFinalExeName
FilePath
installdir InstallMethod
installMethod
in forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) -> IO ()
doInstall forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx
where
overwritePolicy :: OverwritePolicy
overwritePolicy = forall a. a -> Flag a -> a
fromFlagOrDefault OverwritePolicy
NeverOverwrite forall a b. (a -> b) -> a -> b
$
ClientInstallFlags -> Flag OverwritePolicy
cinstOverwritePolicy ClientInstallFlags
clientInstallFlags
isWindows :: Bool
isWindows = OS
buildOS forall a. Eq a => a -> a -> Bool
== OS
Windows
defaultMethod :: IO InstallMethod
defaultMethod :: IO InstallMethod
defaultMethod
| Bool
isWindows = do
Bool
symlinks <- Verbosity -> IO Bool
trySymlink Verbosity
verbosity
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
symlinks then InstallMethod
InstallMethodSymlink else InstallMethod
InstallMethodCopy
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return InstallMethod
InstallMethodSymlink
installLibraries
:: Verbosity
-> ProjectBuildContext
-> PI.PackageIndex InstalledPackageInfo
-> Compiler
-> PackageDBStack
-> FilePath
-> [GhcEnvironmentFileEntry]
-> IO ()
installLibraries :: Verbosity
-> ProjectBuildContext
-> InstalledPackageIndex
-> Compiler
-> PackageDBStack
-> FilePath
-> [GhcEnvironmentFileEntry]
-> IO ()
installLibraries Verbosity
verbosity ProjectBuildContext
buildCtx InstalledPackageIndex
installedIndex Compiler
compiler
PackageDBStack
packageDbs' FilePath
envFile [GhcEnvironmentFileEntry]
envEntries = do
if GhcImplInfo -> Bool
supportsPkgEnvFiles forall a b. (a -> b) -> a -> b
$ Compiler -> GhcImplInfo
getImplInfo Compiler
compiler
then do
let validDb :: PackageDB -> IO Bool
validDb (SpecificPackageDB FilePath
fp) = FilePath -> IO Bool
doesPathExist FilePath
fp
validDb PackageDB
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
PackageDBStack
packageDbs <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM PackageDB -> IO Bool
validDb PackageDBStack
packageDbs'
let
getLatest :: PackageName -> [InstalledPackageInfo]
getLatest = forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (forall a. Maybe a -> [a]
maybeToList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
safeHead forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PI.lookupPackageName InstalledPackageIndex
installedIndex
globalLatest :: [InstalledPackageInfo]
globalLatest = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (PackageName -> [InstalledPackageInfo]
getLatest forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PackageName]
globalPackages)
globalEntries :: [GhcEnvironmentFileEntry]
globalEntries = UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId forall b c a. (b -> c) -> (a -> b) -> a -> c
. InstalledPackageInfo -> UnitId
installedUnitId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [InstalledPackageInfo]
globalLatest
baseEntries :: [GhcEnvironmentFileEntry]
baseEntries =
GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb PackageDBStack
packageDbs
pkgEntries :: [GhcEnvironmentFileEntry]
pkgEntries = forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$
[GhcEnvironmentFileEntry]
globalEntries
forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
envEntries
forall a. [a] -> [a] -> [a]
++ TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents (ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx)
contents' :: FilePath
contents' = [GhcEnvironmentFileEntry] -> FilePath
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry]
baseEntries forall a. [a] -> [a] -> [a]
++ [GhcEnvironmentFileEntry]
pkgEntries)
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> FilePath
takeDirectory FilePath
envFile)
FilePath -> ByteString -> IO ()
writeFileAtomic FilePath
envFile (FilePath -> ByteString
BS.pack FilePath
contents')
else
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"The current compiler doesn't support safely installing libraries, "
forall a. [a] -> [a] -> [a]
++ FilePath
"so only executables will be available. (Library installation is "
forall a. [a] -> [a] -> [a]
++ FilePath
"supported on GHC 8.0+ only)"
globalPackages :: [PackageName]
globalPackages :: [PackageName]
globalPackages = FilePath -> PackageName
mkPackageName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ FilePath
"base" ]
warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes Verbosity
verbosity ProjectBuildContext
buildCtx =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
noExes forall a b. (a -> b) -> a -> b
$
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$
FilePath
"\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"@ WARNING: Installation might not be completed as desired! @\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"* You might have wanted to add them as dependencies to your package." forall a. Semigroup a => a -> a -> a
<>
FilePath
" In this case add \"" forall a. Semigroup a => a -> a -> a
<>
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
", " (TargetSelector -> FilePath
showTargetSelector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TargetSelector]
selectors) forall a. Semigroup a => a -> a -> a
<>
FilePath
"\" to the build-depends field(s) of your package's .cabal file.\n" forall a. Semigroup a => a -> a -> a
<>
FilePath
"* You might have wanted to add them to a GHC environment. In this case" forall a. Semigroup a => a -> a -> a
<>
FilePath
" use \"cabal install --lib " forall a. Semigroup a => a -> a -> a
<>
[FilePath] -> FilePath
unwords (TargetSelector -> FilePath
showTargetSelector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TargetSelector]
selectors) forall a. Semigroup a => a -> a -> a
<> FilePath
"\". " forall a. Semigroup a => a -> a -> a
<>
FilePath
" The \"--lib\" flag is provisional: see" forall a. Semigroup a => a -> a -> a
<>
FilePath
" https://github.com/haskell/cabal/issues/6481 for more information."
where
targets :: [(ComponentTarget, NonEmpty TargetSelector)]
targets = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx
components :: [ComponentTarget]
components = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ComponentTarget, NonEmpty TargetSelector)]
targets
selectors :: [TargetSelector]
selectors = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. NonEmpty a -> [a]
NE.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(ComponentTarget, NonEmpty TargetSelector)]
targets
noExes :: Bool
noExes = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ ComponentTarget -> Maybe UnqualComponentName
exeMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ComponentTarget]
components
exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = forall a. a -> Maybe a
Just UnqualComponentName
exe
exeMaybe ComponentTarget
_ = forall a. Maybe a
Nothing
getEnvSpecsAndNonGlobalEntries
:: PI.InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> Bool
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries :: forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> Bool
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry]
entries Bool
installLibs =
if Bool
installLibs
then (forall {pkg}. [PackageSpecifier pkg]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
envEntries')
else ([], [(PackageName, GhcEnvironmentFileEntry)]
envEntries')
where
([PackageSpecifier a]
envSpecs, [(PackageName, GhcEnvironmentFileEntry)]
envEntries') = forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers InstalledPackageIndex
installedIndex [GhcEnvironmentFileEntry]
entries
environmentFileToSpecifiers
:: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers :: forall a.
InstalledPackageIndex
-> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers InstalledPackageIndex
ipi = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a b. (a -> b) -> a -> b
$ \case
(GhcEnvFilePackageId UnitId
unitId)
| Just InstalledPackageInfo
{ sourcePackageId :: InstalledPackageInfo -> PackageId
sourcePackageId = PackageIdentifier{PackageName
Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageId -> PackageName
pkgVersion :: PackageId -> Version
..}, UnitId
installedUnitId :: UnitId
installedUnitId :: InstalledPackageInfo -> UnitId
installedUnitId }
<- forall a. PackageIndex a -> UnitId -> Maybe a
PI.lookupUnitId InstalledPackageIndex
ipi UnitId
unitId
, let pkgSpec :: PackageSpecifier pkg
pkgSpec = forall pkg.
PackageName -> [PackageProperty] -> PackageSpecifier pkg
NamedPackage PackageName
pkgName
[VersionRange -> PackageProperty
PackagePropertyVersion (Version -> VersionRange
thisVersion Version
pkgVersion)]
-> ([forall {pkg}. PackageSpecifier pkg
pkgSpec], [(PackageName
pkgName, UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId UnitId
installedUnitId)])
GhcEnvironmentFileEntry
_ -> ([], [])
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault ConfigFlags
configFlags =
ConfigFlags
configFlags { configTests :: Flag Bool
configTests = forall a. a -> Flag a
Flag Bool
False forall a. Semigroup a => a -> a -> a
<> ConfigFlags -> Flag Bool
configTests ConfigFlags
configFlags
, configBenchmarks :: Flag Bool
configBenchmarks = forall a. a -> Flag a
Flag Bool
False forall a. Semigroup a => a -> a -> a
<> ConfigFlags -> Flag Bool
configBenchmarks ConfigFlags
configFlags }
installUnitExes
:: Verbosity
-> OverwritePolicy
-> (UnitId -> FilePath)
-> (UnqualComponentName -> FilePath)
-> (UnqualComponentName -> FilePath)
-> FilePath
-> InstallMethod
-> ( UnitId
, [(ComponentTarget, NonEmpty TargetSelector)] )
-> IO ()
installUnitExes :: Verbosity
-> OverwritePolicy
-> (UnitId -> FilePath)
-> (UnqualComponentName -> FilePath)
-> (UnqualComponentName -> FilePath)
-> FilePath
-> InstallMethod
-> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
-> IO ()
installUnitExes Verbosity
verbosity OverwritePolicy
overwritePolicy
UnitId -> FilePath
mkSourceBinDir UnqualComponentName -> FilePath
mkExeName UnqualComponentName -> FilePath
mkFinalExeName
FilePath
installdir InstallMethod
installMethod
(UnitId
unit, [(ComponentTarget, NonEmpty TargetSelector)]
components) =
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ UnqualComponentName -> IO ()
installAndWarn [UnqualComponentName]
exes
where
exes :: [UnqualComponentName]
exes = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ (ComponentTarget -> Maybe UnqualComponentName
exeMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(ComponentTarget, NonEmpty TargetSelector)]
components
exeMaybe :: ComponentTarget -> Maybe UnqualComponentName
exeMaybe (ComponentTarget (CExeName UnqualComponentName
exe) SubComponentTarget
_) = forall a. a -> Maybe a
Just UnqualComponentName
exe
exeMaybe ComponentTarget
_ = forall a. Maybe a
Nothing
installAndWarn :: UnqualComponentName -> IO ()
installAndWarn UnqualComponentName
exe = do
Bool
success <- Verbosity
-> OverwritePolicy
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> InstallMethod
-> IO Bool
installBuiltExe
Verbosity
verbosity OverwritePolicy
overwritePolicy
(UnitId -> FilePath
mkSourceBinDir UnitId
unit) (UnqualComponentName -> FilePath
mkExeName UnqualComponentName
exe)
(UnqualComponentName -> FilePath
mkFinalExeName UnqualComponentName
exe)
FilePath
installdir InstallMethod
installMethod
let errorMessage :: FilePath
errorMessage = case OverwritePolicy
overwritePolicy of
OverwritePolicy
NeverOverwrite ->
FilePath
"Path '" forall a. Semigroup a => a -> a -> a
<> (FilePath
installdir FilePath -> FilePath -> FilePath
</> forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe) forall a. Semigroup a => a -> a -> a
<> FilePath
"' already exists. "
forall a. Semigroup a => a -> a -> a
<> FilePath
"Use --overwrite-policy=always to overwrite."
OverwritePolicy
_ ->
case InstallMethod
installMethod of
InstallMethod
InstallMethodSymlink -> FilePath
"Symlinking"
InstallMethod
InstallMethodCopy ->
FilePath
"Copying" forall a. Semigroup a => a -> a -> a
<> FilePath
" '" forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
exe forall a. Semigroup a => a -> a -> a
<> FilePath
"' failed."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success forall a b. (a -> b) -> a -> b
$ forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity FilePath
errorMessage
installBuiltExe
:: Verbosity -> OverwritePolicy
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> InstallMethod
-> IO Bool
installBuiltExe :: Verbosity
-> OverwritePolicy
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> InstallMethod
-> IO Bool
installBuiltExe Verbosity
verbosity OverwritePolicy
overwritePolicy
FilePath
sourceDir FilePath
exeName FilePath
finalExeName
FilePath
installdir InstallMethod
InstallMethodSymlink = do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Symlinking '" forall a. Semigroup a => a -> a -> a
<> FilePath
exeName forall a. Semigroup a => a -> a -> a
<> FilePath
"' to '" forall a. Semigroup a => a -> a -> a
<> FilePath
destination forall a. Semigroup a => a -> a -> a
<> FilePath
"'"
OverwritePolicy
-> FilePath -> FilePath -> FilePath -> FilePath -> IO Bool
symlinkBinary
OverwritePolicy
overwritePolicy
FilePath
installdir
FilePath
sourceDir
FilePath
finalExeName
FilePath
exeName
where
destination :: FilePath
destination = FilePath
installdir FilePath -> FilePath -> FilePath
</> FilePath
finalExeName
installBuiltExe Verbosity
verbosity OverwritePolicy
overwritePolicy
FilePath
sourceDir FilePath
exeName FilePath
finalExeName
FilePath
installdir InstallMethod
InstallMethodCopy = do
Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Copying '" forall a. Semigroup a => a -> a -> a
<> FilePath
exeName forall a. Semigroup a => a -> a -> a
<> FilePath
"' to '" forall a. Semigroup a => a -> a -> a
<> FilePath
destination forall a. Semigroup a => a -> a -> a
<> FilePath
"'"
Bool
exists <- FilePath -> IO Bool
doesPathExist FilePath
destination
case (Bool
exists, OverwritePolicy
overwritePolicy) of
(Bool
True , OverwritePolicy
NeverOverwrite ) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
(Bool
True , OverwritePolicy
AlwaysOverwrite) -> IO Bool
overwrite
(Bool
True , OverwritePolicy
PromptOverwrite) -> IO Bool
maybeOverwrite
(Bool
False, OverwritePolicy
_ ) -> IO Bool
copy
where
source :: FilePath
source = FilePath
sourceDir FilePath -> FilePath -> FilePath
</> FilePath
exeName
destination :: FilePath
destination = FilePath
installdir FilePath -> FilePath -> FilePath
</> FilePath
finalExeName
remove :: IO ()
remove = do
Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
destination
if Bool
isDir
then FilePath -> IO ()
removeDirectory FilePath
destination
else FilePath -> IO ()
removeFile FilePath
destination
copy :: IO Bool
copy = FilePath -> FilePath -> IO ()
copyFile FilePath
source FilePath
destination forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
overwrite :: IO Bool
overwrite :: IO Bool
overwrite = IO ()
remove forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Bool
copy
maybeOverwrite :: IO Bool
maybeOverwrite :: IO Bool
maybeOverwrite
= FilePath -> IO Bool -> IO Bool
promptRun
FilePath
"Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
IO Bool
overwrite
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
entriesForLibraryComponents = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey' (\UnitId
k [(ComponentTarget, NonEmpty TargetSelector)]
v -> forall a. Monoid a => a -> a -> a
mappend (UnitId
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GhcEnvironmentFileEntry]
go UnitId
k [(ComponentTarget, NonEmpty TargetSelector)]
v)) []
where
hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool
hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool
hasLib (ComponentTarget (CLibName LibraryName
_) SubComponentTarget
_, NonEmpty TargetSelector
_) = Bool
True
hasLib (ComponentTarget, NonEmpty TargetSelector)
_ = Bool
False
go :: UnitId
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GhcEnvironmentFileEntry]
go :: UnitId
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GhcEnvironmentFileEntry]
go UnitId
unitId [(ComponentTarget, NonEmpty TargetSelector)]
targets
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ComponentTarget, NonEmpty TargetSelector) -> Bool
hasLib [(ComponentTarget, NonEmpty TargetSelector)]
targets = [UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId UnitId
unitId]
| Bool
otherwise = []
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
getEnvFile ClientInstallFlags
clientInstallFlags Platform
platform Version
compilerVersion = do
FilePath
appDir <- IO FilePath
getGhcAppDir
case forall a. Flag a -> Maybe a
flagToMaybe (ClientInstallFlags -> Flag FilePath
cinstEnvironmentPath ClientInstallFlags
clientInstallFlags) of
Just FilePath
spec
| FilePath -> FilePath
takeBaseName FilePath
spec forall a. Eq a => a -> a -> Bool
== FilePath
spec ->
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Platform -> Version -> FilePath -> FilePath
getGlobalEnv FilePath
appDir Platform
platform Version
compilerVersion FilePath
spec)
| Bool
otherwise -> do
FilePath
spec' <- FilePath -> IO FilePath
makeAbsolute FilePath
spec
Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
spec'
if Bool
isDir
then forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Platform -> Version -> FilePath
getLocalEnv FilePath
spec' Platform
platform Version
compilerVersion)
else forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
spec'
Maybe FilePath
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Platform -> Version -> FilePath -> FilePath
getGlobalEnv FilePath
appDir Platform
platform Version
compilerVersion FilePath
"default")
getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries :: Verbosity
-> CompilerFlavor
-> Bool
-> FilePath
-> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries Verbosity
verbosity CompilerFlavor
compilerFlavor Bool
supportsPkgEnvFiles FilePath
envFile = do
Bool
envFileExists <- FilePath -> IO Bool
doesFileExist FilePath
envFile
[GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
filterEnvEntries forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if
(CompilerFlavor
compilerFlavor forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHC Bool -> Bool -> Bool
|| CompilerFlavor
compilerFlavor forall a. Eq a => a -> a -> Bool
== CompilerFlavor
GHCJS)
Bool -> Bool -> Bool
&& Bool
supportsPkgEnvFiles Bool -> Bool -> Bool
&& Bool
envFileExists
then forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (FilePath -> IO [GhcEnvironmentFileEntry]
readGhcEnvironmentFile FilePath
envFile) forall a b. (a -> b) -> a -> b
$ \(ParseErrorExc
_ :: ParseErrorExc) ->
Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath
"The environment file " forall a. [a] -> [a] -> [a]
++ FilePath
envFile forall a. [a] -> [a] -> [a]
++
FilePath
" is unparsable. Libraries cannot be installed.") forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return []
else forall (m :: * -> *) a. Monad m => a -> m a
return []
where
filterEnvEntries :: [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
filterEnvEntries = forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a -> b) -> a -> b
$ \case
GhcEnvFilePackageId UnitId
_ -> Bool
True
GhcEnvironmentFileEntry
_ -> Bool
False
getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath
getGlobalEnv :: FilePath -> Platform -> Version -> FilePath -> FilePath
getGlobalEnv FilePath
appDir Platform
platform Version
compilerVersion FilePath
name =
FilePath
appDir FilePath -> FilePath -> FilePath
</> Platform -> Version -> FilePath
ghcPlatformAndVersionString Platform
platform Version
compilerVersion
FilePath -> FilePath -> FilePath
</> FilePath
"environments" FilePath -> FilePath -> FilePath
</> FilePath
name
getLocalEnv :: FilePath -> Platform -> Version -> FilePath
getLocalEnv :: FilePath -> Platform -> Version -> FilePath
getLocalEnv FilePath
dir Platform
platform Version
compilerVersion =
FilePath
dir FilePath -> FilePath -> FilePath
</>
FilePath
".ghc.environment." forall a. Semigroup a => a -> a -> a
<> Platform -> Version -> FilePath
ghcPlatformAndVersionString Platform
platform Version
compilerVersion
getPackageDbStack
:: CompilerId
-> Flag FilePath
-> Flag FilePath
-> IO PackageDBStack
getPackageDbStack :: CompilerId -> Flag FilePath -> Flag FilePath -> IO PackageDBStack
getPackageDbStack CompilerId
compilerId Flag FilePath
storeDirFlag Flag FilePath
logsDirFlag = do
Maybe FilePath
mstoreDir <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse FilePath -> IO FilePath
makeAbsolute forall a b. (a -> b) -> a -> b
$ forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
storeDirFlag
let
mlogsDir :: Maybe FilePath
mlogsDir = forall a. Flag a -> Maybe a
flagToMaybe Flag FilePath
logsDirFlag
CabalDirLayout
cabalLayout <- Maybe FilePath -> Maybe FilePath -> IO CabalDirLayout
mkCabalDirLayout Maybe FilePath
mstoreDir Maybe FilePath
mlogsDir
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ StoreDirLayout -> CompilerId -> PackageDBStack
storePackageDBStack (CabalDirLayout -> StoreDirLayout
cabalStoreDirLayout CabalDirLayout
cabalLayout) CompilerId
compilerId
selectPackageTargets
:: TargetSelector
-> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets :: forall k.
TargetSelector
-> [AvailableTarget k] -> Either (TargetProblem Void) [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable)
= forall a b. b -> Either a b
Right [k]
targetsBuildable
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets)
= forall a b. a -> Either a b
Left (forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')
| Bool
otherwise
= forall a b. a -> Either a b
Left (forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
where
targets' :: [AvailableTarget ()]
targets' = forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
targetsBuildable :: [k]
targetsBuildable = forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith
(TargetSelector -> TargetRequested -> Bool
buildable TargetSelector
targetSelector)
[AvailableTarget k]
targets
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
selectComponentTarget
:: SubComponentTarget
-> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget :: forall k.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem Void) k
selectComponentTarget = forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic
reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildTargetProblems :: forall a. Verbosity -> [TargetProblem Void] -> IO a
reportBuildTargetProblems Verbosity
verbosity [TargetProblem Void]
problems = forall a. Verbosity -> FilePath -> [TargetProblem Void] -> IO a
reportTargetProblems Verbosity
verbosity FilePath
"build" [TargetProblem Void]
problems
reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies :: forall a. Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies Verbosity
verbosity =
forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall b c a. (b -> c) -> (a -> b) -> a -> c
. CannotPruneDependencies -> FilePath
renderCannotPruneDependencies